VBA字典写入WORD文档求救

kangkumbong

你好  请教大神们！

遇到问题 数组字典写入WORD文档
分类汇总的数据（下方红色字体代码）
写入单元格正常，写入WORD文档不显示
写入其他数组正常，就是分类汇总的字典KEYS , ITEMS不知该如何提前写入WORD文档
不知该怎么提取写入


谢谢

Sub PACKINGLIST()
On Error Resume Next
Dim arr, brr, brr1, brr2, i, n
Set dic = CreateObject("scripting.dictionary")
Set dic1 = CreateObject("scripting.dictionary")
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Path = "D:\SM\CIELO ORDER\PACKING LIST" & "\"
arr = Sheets("PACKING LIST").Range("A1").CurrentRegion
        Sheets("DELIVERY DETAILS").Copy
            For x = 19 To UBound(arr)
                r = Range("B100").End(xlUp).Row + 1
                Range("b" & r) = arr(x, 2)
                Range("c" & r) = arr(x, 13)
                Range("d" & r) = arr(x, 3)
                Range("e" & r) = arr(x, 22)
                Range("f" & r) = arr(5, 14)
                Range("h" & r) = arr(x, 1)
                Range("i" & r) = arr(x, 1)
                Range("j" & r) = arr(x, 7)
                    If Range("h" & r) = "" Then
                        Range("h" & r - 1).Resize(2).Merge
                    End If
                    If Range("i" & r) = "" Then
                        Range("i" & r - 1).Resize(2).Merge
                    End If
                For i = UBound(arr) - 1 To 1 Step -1
                    If arr(i, 1) <> "" Then
                       T = arr(i, 1)
                    Range("i" & r) = T
                    Exit For
                    End If
                Next i
            Next x
         Rows(r & ":100").Delete
         path1 = arr(3, 14) & " " & T & "CT" & " " & arr(12, 14) & " " & "Jewellery AND HAIR delivery form template(QINGDAO)"
         MkDir Path & path1
         ActiveWorkbook.SaveAs Path & path1 & "\" & arr(3, 14) & " " & T & "CT" & " " & arr(12, 14) & " " & "Jewellery AND HAIR delivery form template(QINGDAO).xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
         ActiveWorkbook.Close
  MsgBox "DELIVERY DETAILS已生成完毕"
    For n = 19 To UBound(arr)
        If (arr(n, 2)) <> "" Then
           dic(arr(n, 2)) = ""
        End If
    Next n
brr = dic.keys
    For n = 0 To UBound(brr)
        Sheets("COMMERCIAL INVOICE AND PACKING").Copy
            Range("f3") = arr(3, 14)
            Range("f5") = arr(5, 14)
            Range("f14") = arr(12, 14)
            Range("g14") = brr(n)
            For x = 19 To UBound(arr)
                If arr(x, 2) = brr(n) Then
                    r = Range("b100").End(xlUp).Row + 1
                    Range("a" & r) = arr(x, 2)
                    Range("b" & r) = arr(x, 3)
                    Range("c" & r) = arr(x, 5)
                    Range("d" & r) = arr(x, 6)
                    Range("e" & r) = arr(x, 7)
                    Range("h" & r) = arr(x, 1)
                    Range("i" & r) = arr(x, 17)
                    Range("j" & r) = arr(x, 18)
                    Range("k" & r) = arr(x, 19)
                    If Range("h" & r) = "" Then
                        Range("h" & r - 1).Resize(2).Merge
                    End If
                    If Range("i" & r) = "" Then
                        Range("i" & r - 1).Resize(2).Merge
                    End If
                    If Range("j" & r) = "" Then
                        Range("j" & r - 1).Resize(2).Merge
                    End If
                    If Range("k" & r) = "" Then
                        Range("k" & r - 1).Resize(2).Merge
                    End If
                End If
            Next x
         r = Range("b100").End(xlUp).Row + 1
         Rows(r & ":100").Delete
         ActiveSheet.Name = brr(n)
         ActiveWorkbook.SaveAs Path & path1 & "\" & arr(3, 14) & " " & brr(n) & " " & "CI and PL (QINGDAO)" & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
         ActiveWorkbook.Close
         Sheets("PACKING LIST").Copy
         ActiveWorkbook.SaveAs Path & arr(3, 14) & " " & T & "CT" & " " & arr(12, 14) & " " & "D-DATE" & " " & arr(5, 14) & " " & "OB PACKING LIST" & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
         ActiveWorkbook.Close
    Next n
MsgBox UBound(brr) + 1 & "份COMMERCIAL INVOICE AND PACKING已生成完毕"
'For i = 19 To UBound(arr)
'    dic1(arr(i, 2)) = dic1(arr(i, 2)) + arr(i, 7)
'    Next i
'    brr1 = dic1.keys
'    brr2 = dic1.items
'    Range("x18:y100").ClearContents
'    [x18].Resize(dic1.Count, 1) = WorksheetFunction.Transpose(dic1.keys)
'    [y18].Resize(dic1.Count, 1) = WorksheetFunction.Transpose(dic1.items)
Dim wdcx As Object
Dim wd As Object
Set wdcx = CreateObject("word.application")
Set wd = wdcx.documents.Open(Path & "\Jewellery AND HAIR delivery form template(QINGDAO).docx")
wdcx.Visible = True
    With wdcx
        .ActiveDocument.Tables(2).Cell(4, 2).Select
        .Selection.Range.Text = arr(5, 14)
        .ActiveDocument.Tables(2).Cell(4, 3).Select
        .Selection.Range.Text = arr(5, 14)
        .ActiveDocument.Tables(4).Cell(2, 2).Select
        .Selection.Range.Text = T & "CTN"
        .ActiveDocument.Tables(4).Cell(2, 3).Select
        .Selection.Range.Text = arr(x - 1, 18) & "Kg" & " " & arr(x - 1, 20) & "CBM"
'        .ActiveDocument.Tables(5).Cell(2, 2).Select
'        .Selection.Range.Text =
        .ActiveDocument.Tables(5).Cell(3, 2).Select
        .Selection.Range.Text = arr(x - 1, 7) & " " & "PCS"
    End With
wd.SaveAs Path & path1 & "\" & arr(3, 14) & " " & T & "CT" & " " & arr(12, 14) & " " & "Jewellery AND HAIR delivery form template(QINGDAO).docx"
wd.Close
wdcx.Quit
Set wdcx = Nothing
Set wd = Nothing
MsgBox "Courier Booking Sheet文件已生成"
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub