返回列表 回复 发帖

黄杨宁片:治疗冠心病引起的胸闷、心痛、心绞痛等:特别适合早期冠心病,如果及时服药可免于因冠心病引起的猝死,血管阻塞60-70%以内均可服用达到治疗目的.本品10盒一疗程,初次服用者3疗程为一个治疗期,一般患者需要连续服用半年。等症状消失后前往医院做检查,医学上称为冠心病不成立时。还需巩固2-3疗程即可,此后患者需要戒烟戒酒1年以上,为了防止复发请患者遵循健康饮食和生活习惯。
详情
http://iylqx.cn/space-197-do-blog-id-1213.html
分享到:


  1. Sub CFGZB()
  2.     Dim myRange As Variant
  3.     Dim myArray
  4.     Dim titleRange As Range
  5.     Dim title As String
  6.     Dim columnNum As Integer
  7.     myRange = Application.InputBox(prompt:="请选择标题行:", Type:=8)
  8.     myArray = WorksheetFunction.Transpose(myRange)
  9.     Set titleRange = Application.InputBox(prompt:="请选择拆分的表头,必须是第一行,且为一个单元格,如:“姓名”", Type:=8)
  10.     title = titleRange.Value
  11.     columnNum = titleRange.Column
  12.     Application.ScreenUpdating = False
  13.     Application.DisplayAlerts = False
  14.     Dim i&, Myr&, Arr, num&
  15.     Dim d, k
  16.     For i = Sheets.Count To 1 Step -1
  17.         If Sheets(i).Name <> "数据源" Then
  18.             Sheets(i).Delete
  19.         End If
  20.     Next i
  21.     Set d = CreateObject("Scripting.Dictionary")
  22.     Myr = Worksheets("数据源").UsedRange.Rows.Count
  23.     Arr = Worksheets("数据源").Range(Cells(2, columnNum), Cells(Myr, columnNum))
  24.     For i = 1 To UBound(Arr)
  25.         d(Arr(i, 1)) = ""
  26.     Next
  27.     k = d.keys
  28.     For i = 0 To UBound(k)
  29.         Set conn = CreateObject("adodb.connection")
  30.         conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
  31.         Sql = "select * from [数据源$] where " & title & " = '" & k(i) & "'"
  32.         Worksheets.Add after:=Sheets(Sheets.Count)
  33.         With ActiveSheet
  34.             .Name = k(i)
  35.             For num = 1 To UBound(myArray)
  36.                 .Cells(1, num) = myArray(num, 1)
  37.             Next num
  38.             .Range("A2").CopyFromRecordset conn.Execute(Sql)
  39.         End With
  40.         Sheets(1).Select
  41.         Sheets(1).Cells.Select
  42.         Selection.Copy
  43.         Worksheets(Sheets.Count).Activate
  44.         ActiveSheet.Cells.Select
  45.         Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
  46.                                SkipBlanks:=False, Transpose:=False
  47.         Application.CutCopyMode = False
  48.     Next i
  49.     conn.Close
  50.     Set conn = Nothing
  51.     Application.DisplayAlerts = True
  52.     Application.ScreenUpdating = True
  53. End Sub
复制代码
返回列表

站长推荐 关闭


本站楼层广告位出售

本站楼层广告销售中,1楼不售,2楼开始起家每年1200元现金,不按月售,至少按年出售 每下一楼减100元元/年, 10楼以下每年800元不再递减 本站注册会员可用积分兑 ...


查看
会员请注意:对于交易交友信息我们不对此核实,请您多加留意考证其真实性,为此发生的法律问题我们概不承担!切记阿妹的忠告