筆記：VBA在日常工作的應(yīng)用（1）

用于日常工作中由Excel數(shù)據(jù)表格生成相應(yīng)的word報告。
源代碼如下：

Public directory As String
Public table_num As Long
Sub 執(zhí)行()
directory = "example1.xlsx" '修改這個目錄
table_num = 1

'''''''在此處按F5執(zhí)行即可
Selection.TypeText Text:="一、檢測結(jié)果綜合指導(dǎo)"
Selection.TypeParagraph
Call 表格1
Selection.TypeText Text:="二、陽性結(jié)果解讀"
Selection.TypeParagraph
Call 讀取數(shù)據(jù)1
Selection.TypeText Text:="三、基因檢測結(jié)果總覽"
Selection.TypeParagraph
Call 基因1
End Sub

Sub 讀取數(shù)據(jù)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 <> "網(wǎng)格型" Then
                    .Style = "網(wǎng)格型"
                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:="結(jié)果解釋:" & 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 <> "網(wǎng)格型" Then
                    .Style = "網(wǎng)格型"
                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:="結(jié)果解釋:" & 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 <> "網(wǎng)格型" Then
                .Style = "網(wǎng)格型"
            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:="用藥指導(dǎo)"
        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 <> "網(wǎng)格型" Then
                .Style = "網(wǎng)格型"
            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:="用藥指導(dǎo)"
        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 <> "網(wǎng)格型" Then
                .Style = "網(wǎng)格型"
            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:="用藥指導(dǎo)"
        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 <> "網(wǎng)格型" Then
                .Style = "網(wǎng)格型"
            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

數(shù)據(jù)下載地址：
鏈接：https://pan.baidu.com/s/1RKgYn7KbOSOb_CkcN0U51g
提取碼：ycvd
新建打開word，Alt+F11 進入VBA編寫，復(fù)制粘貼以上代碼，按提示修改文件所在目錄，F(xiàn)5執(zhí)行后等待生成word即可。

最后編輯于 ：
?著作權(quán)歸作者所有,轉(zhuǎn)載或內(nèi)容合作請聯(lián)系作者
【社區(qū)內(nèi)容提示】社區(qū)部分內(nèi)容疑似由AI輔助生成，瀏覽時請結(jié)合常識與多方信息審慎甄別。
平臺聲明：文章內(nèi)容（如有圖片或視頻亦包括在內(nèi)）由作者上傳并發(fā)布，文章內(nèi)容僅代表作者本人觀點，簡書系信息發(fā)布平臺，僅提供信息存儲服務(wù)。

友情鏈接更多精彩內(nèi)容