笔记：VBA在日常工作的应用（1）
2019-04-04 本文已影响14人
xianmao123
用于日常工作中由Excel数据表格生成相应的word报告。
源代码如下：
Public directory As String
Public table_num As Long
Sub 执行()
directory = "example1.xlsx" '修改这个目录
table_num = 1
'''''''在此处按F5执行即可
Selection.TypeText Text:="一、检测结果综合指导"
Selection.TypeParagraph
Call 表格1
Selection.TypeText Text:="二、阳性结果解读"
Selection.TypeParagraph
Call 读取数据1
Selection.TypeText Text:="三、基因检测结果总览"
Selection.TypeParagraph
Call 基因1
End Sub
Sub 读取数据1()
Application.DisplayAlerts = False
Set wo = CreateObject("excel.application")
wo.Visible = False
wo.Workbooks.Open (directory)
data_number = wo.Worksheets(table_num).UsedRange.Rows.Count
range_A = "A2:A" & data_number
range_C = "C2:C" & data_number
range_D = "D2:D" & data_number
range_E = "E2:E" & data_number
range_H = "H2:H" & data_number
arr_rs = wo.Range(range_A).Value
arr_result = wo.Range(range_C).Value
arr_propose = wo.Range(range_D).Value
arr_drug = wo.Range(range_E).Value
arr_intro = wo.Range(range_H).Value
wo.Quit
Application.DisplayAlerts = True
j = 1
For i = 1 To data_number - 1 Step 1
If arr_propose(i, 1) = "正常用药" Then
GoTo p
End If
If arr_rs(i, 1) Like "*；*" Then
array_data = Split(arr_rs(i, 1), "；")
Selection.TypeText Text:=j & "." & arr_drug(i, 1)
Selection.TypeParagraph
Selection.TypeText Text:="药物介绍:" & arr_intro(i, 1)
Selection.TypeParagraph
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=UBound(array_data) + 2, NumColumns:= _3, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _wdAutoFitFixed
With Selection.Tables(1)
If .Style <> "网格型" Then
.Style = "网格型"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
End With
Selection.TypeText Text:="基因名"
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:="检测位点编号"
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:="基因型"
For k = 0 To UBound(array_data) Step 1
array_string = Split(array_data(k), "|")
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=array_string(0)
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=array_string(1)
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=array_string(2)
Next k
Selection.MoveDown Unit:=wdLine, Count:=1
If arr_propose(i, 1) <> "正常用药" Then
Selection.TypeText Text:="结果解释:" & arr_propose(i, 1)
Selection.TypeParagraph
Selection.TypeText Text:=arr_result(i, 1)
Selection.TypeParagraph
End If
Else
If arr_propose(i, 1) = "正常用药" Then
GoTo p
End If
array_string = Split(arr_rs(i, 1), "|")
Selection.TypeText Text:=j & "." & arr_drug(i, 1)
Selection.TypeParagraph
Selection.TypeText Text:="药物介绍:" & arr_intro(i, 1)
Selection.TypeParagraph
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=2, NumColumns:= _3, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _wdAutoFitFixed
With Selection.Tables(1)
If .Style <> "网格型" Then
.Style = "网格型"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
End With
Selection.TypeText Text:="基因名"
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:="检测位点编号"
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:="基因型"
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=array_string(0)
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=array_string(1)
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=array_string(2)
Selection.MoveDown Unit:=wdLine, Count:=1
If arr_propose(i, 1) <> "正常用药" Then
Selection.TypeText Text:="结果解释:" & arr_propose(i, 1)
Selection.TypeParagraph
Selection.TypeText Text:=arr_result(i, 1)
Selection.TypeParagraph
End If
End If
j = j + 1
p:
Next i
End Sub
Sub 表格1()
Application.DisplayAlerts = False
Set wo = CreateObject("excel.application")
wo.Visible = False
wo.Workbooks.Open (directory)
data_number = wo.Worksheets(table_num).UsedRange.Rows.Count
range_A = "A2:A" & data_number
range_D = "D2:D" & data_number
range_E = "E2:E" & data_number
range_F = "F2:F" & data_number
range_G = "G2:G" & data_number
arr_rs = wo.Range(range_A).Value
arr_D = wo.Range(range_D).Value
arr_E = wo.Range(range_E).Value
arr_F = wo.Range(range_F).Value
arr_G = wo.Range(range_G).Value
wo.Quit
Application.DisplayAlerts = True
array_data1 = Split(arr_rs(1, 1), "；")
j = 1
Selection.TypeText Text:=j & "." & arr_G(1, 1)
Selection.TypeParagraph
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=2, NumColumns:= _
4, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed
With Selection.Tables(1)
If .Style <> "网格型" Then
.Style = "网格型"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
End With
Selection.TypeText Text:="药物名称"
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:="常见商品名"
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:="检测基因"
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:="用药指导"
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=arr_E(1, 1)
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=arr_F(1, 1)
Selection.MoveRight Unit:=wdCell
For k = 0 To UBound(array_data1) Step 1
array_string = Split(array_data1(k), "|")
Selection.TypeText Text:=array_string(0)
Selection.TypeParagraph
Next k
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=arr_D(1, 1)
For i = 2 To data_number - 1 Step 1
If arr_G(i, 1) <> arr_G(i - 1, 1) Then
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.TypeText Text:=j + 1 & "." & arr_G(i, 1)
j = j + 1
Selection.TypeParagraph
If arr_rs(i, 1) Like "*；*" Then
array_data = Split(arr_rs(i, 1), "；")
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=2, NumColumns:= _
4, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed
With Selection.Tables(1)
If .Style <> "网格型" Then
.Style = "网格型"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
End With
Selection.TypeText Text:="药物名称"
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:="常见商品名"
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:="检测基因"
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:="用药指导"
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=arr_E(i, 1)
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=arr_F(i, 1)
Selection.MoveRight Unit:=wdCell
p = 1
For k = 0 To UBound(array_data) Step 1
Dim arr(1 To 50)
array_string = Split(array_data(k), "|")
arr(p) = array_string(0)
If p = 1 Then
GoTo a
End If
If arr(p) = arr(p - 1) Then
GoTo b
End If
a:
p = p + 1
Selection.TypeText Text:=array_string(0)
Selection.TypeParagraph
b:
Next k
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=arr_D(i, 1)
Else
array_string = Split(arr_rs(i, 1), "|")
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=2, NumColumns:= _
4, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed
With Selection.Tables(1)
If .Style <> "网格型" Then
.Style = "网格型"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
End With
Selection.TypeText Text:="药物名称"
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:="常见商品名"
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:="检测基因"
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:="用药指导"
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=arr_E(i, 1)
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=arr_F(i, 1)
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=array_string(0)
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=arr_D(i, 1)
End If
Else
Selection.InsertRowsBelow 1
If arr_rs(i, 1) Like "*；*" Then
array_data = Split(arr_rs(i, 1), "；")
Selection.TypeText Text:=arr_E(i, 1)
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=arr_F(i, 1)
Selection.MoveRight Unit:=wdCell
p = 1
For k = 0 To UBound(array_data) Step 1
Dim arra(1 To 50)
array_string = Split(array_data(k), "|")
arra(p) = array_string(0)
If p = 1 Then
GoTo c
End If
If arra(p) = arra(p - 1) Then
GoTo d
End If
c:
p = p + 1
Selection.TypeText Text:=array_string(0)
Selection.TypeParagraph
d:
Next k
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=arr_D(i, 1)
Else
array_string = Split(arr_rs(i, 1), "|")
Selection.TypeText Text:=arr_E(i, 1)
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=arr_F(i, 1)
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=array_string(0)
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=arr_D(i, 1)
End If
End If
Next i
Selection.MoveDown Unit:=wdLine, Count:=1
End Sub
Sub 基因1()
Application.DisplayAlerts = False
Set wo = CreateObject("excel.application")
wo.Visible = False
wo.Workbooks.Open (directory)
data_number = wo.Worksheets(2).UsedRange.Rows.Count
range_A = "A2:A" & data_number
range_B = "B2:B" & data_number
range_G = "G2:G" & data_number
arr_A = wo.Range(range_A).Value
arr_B = wo.Range(range_B).Value
arr_G = wo.Range(range_G).Value
wo.Quit
Application.DisplayAlerts = True
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=data_number, NumColumns:= _
3, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutocontent
With Selection.Tables(1)
If .Style <> "网格型" Then
.Style = "网格型"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
End With
Selection.TypeText Text:="基因名"
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:="检测位点编号"
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:="基因型"
For i = 1 To data_number - 1 Step 1
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=arr_A(i, 1)
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=arr_B(i, 1)
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=arr_G(i, 1)
Next i
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.TypeParagraph
End Sub
数据下载地址：
链接：https://pan.baidu.com/s/1RKgYn7KbOSOb_CkcN0U51g
提取码：ycvd
新建打开word，Alt+F11 进入VBA编写，复制粘贴以上代码，按提示修改文件所在目录，F5执行后等待生成word即可。
