急救！！！ VBA 批量导入和批量导出标准表格

鱼儿5610

各位高手：
    最近手上有几千行数据（见索赔明细），每一行代表对一个供应商的索赔信息（包括供应商名称、原始金额、供应商名称、索赔单编号、索赔产品、数量、发生月份等），需要将索赔明细中每一行的信息对应复制黏贴到标准表格对应的阴影区域，由于数据量太大。而且是重复的动作，不知道可以用VBA实现吗？急用，万分感谢
    其中标准表格中阴影区域的数据来源如下：
    GX2016090476 来源于 索赔明细中 索赔单编号
    2016-9-2     来源于 索赔明细中  制单日期
   黎明液压有限公司  来源于 索赔明细中 供应商名称
    蒋经理  来源于 标准通讯录中 黎明液压有限公司对应的联系人，如果标准通讯录中未找到该供应商名称，那么联系人、电话、传真均空白，其他工作继续进行
      3775893399     来源于 标准通讯录中蒋经理对应电话
       7732760       来源于 标准通讯录中蒋经理对应传真，如没有就空着
     过滤器  来源于  索赔明细中 索赔产品
         13  来源于  索赔明细中 数量
    2016年8月  来源于 索赔明细中 发生月份
    230  来源于   索赔明细中    原始金额
  269.1  来源于    索赔明细中  索赔单金额

     希望将每一行转化为索赔单之后，另存为excel表，保存在桌面上“索赔单”文件夹，且表格的名字命名方式为：索赔单编号后六位数字+供应商名称，本例子最后生成的excel名称应为“090476黎明液压有限公司”。     

yayahzmeng

请测试一下！
3分半，生成200份索赔单，个人觉得不太满意

1. Sub autoT()
   
2. Application.ScreenUpdating = False
   
3. 
   
4.     Dim arr, brr, Mxi, Tongx, t, i&, j%, k%, a, b, facN
   
5.     Dim wb As Workbook, wk As Workbook
   
6.     Dim sh As Worksheet, ipath
   
7.     t = Timer
   
8.     ipath = ThisWorkbook.Path & "\索赔单"
   
9.     Set Mxi = CreateObject("scripting.dictionary")
   
10.     Set Tongx = CreateObject("scripting.dictionary")
    
11.     arr = Array("J4", "D5", "C17", "A17", "c4", "D8", "J8", "H10", "D10", "J10", "I21")
    
12.     brr = Array("I6", "J6", "I7")
    
13.     '清空标准表单
    
14.     For i = 0 To UBound(arr)
    
15.         Range(arr(i)) = ""
    
16.     Next
    
17.     For i = 0 To UBound(brr)
    
18.         Range(brr(i)) = ""
    
19.     Next
    
20.     Set wb = Workbooks.Open(ThisWorkbook.Path & "\索赔明细.xlsx")
    
21.     '    wb.Sheet1.Activate
    
22.         With ActiveSheet
    
23.         a = .Range("A2:I" & .[a1].End(4).Row)
    
24.         For i = 1 To UBound(a)
    
25.             For j = 2 To 9
    
26.                 Mxi(a(i, 1)) = Mxi(a(i, 1)) & a(i, j) & vbTab
    
27.             Next
    
28.         Next
    
29.         End With
    
30.         Erase a: wb.Close False: i = 1
    
31.         Set wb = Nothing
    
32. '
    
33. '        '按Mxi序号批量建立sheets
    
34. '        For i = 1 To Mxi.Count
    
35. '            If TypeName(Application.Evaluate("(" & i & ")!A1")) = "Error" Then
    
36. '                Sheets("标准").Copy after:=Worksheets(Worksheets.Count)
    
37. '                With ActiveSheet
    
38. '                    .Name = "(" & i & ")"
    
39. '                End With
    
40. '            End If
    
41. '        Next
    
42.         
    
43.     Set wb = Workbooks.Open(ThisWorkbook.Path & "\标准通讯录.xls")
    
44.         With ActiveSheet
    
45.             a = .Range("D2:G" & .[d2].End(4).Row)
    
46.             For i = 1 To UBound(a)
    
47.                 Tongx(a(i, 1)) = a(i, 2) & vbTab & a(i, 3) & vbTab & a(i, 4)
    
48.             Next
    
49.         End With
    
50.         Erase a: wb.Close False
    
51.         Set wb = Nothing
    
52.    
    
53.     For i = 1 To Mxi.Count
    
54.         a = Split(Mxi(i), vbTab)
    
55.         With ActiveSheet
    
56.             For k = 0 To UBound(arr) Step 1
    
57.                 If k <= 7 Then
    
58.                     .Range(arr(k)) = a(k)
    
59.                 End If
    
60.                 If k = 8 Then .Range(arr(k)) = a(5)
    
61.                 If k = 9 Then .Range(arr(k)) = a(6)
    
62.                 If k = 10 Then .Range(arr(k)) = a(2)
    
63.             Next
    
64.             formN = Right(a(4), 6)
    
65.             Erase a
    
66.             facN = .Range(arr(1))
    
67.             b = Split(Tongx(facN), vbTab)
    
68.             For j = 0 To UBound(brr)
    
69.                 .Range(brr(j)) = "" & b(j)
    
70.             Next
    
71.             Erase b
    
72.             fname = formN & facN
    
73.             Set wk = Workbooks.Add
    
74.              .Copy before:=wk.Worksheets("sheet1")
    
75. 
    
76.             For Each sh In wk.Worksheets
    
77.                  If sh.Name Like "*Sheet*" Then
    
78.                     Application.DisplayAlerts = False
    
79.                     sh.Delete
    
80.                     Application.DisplayAlerts = True
    
81.                  End If
    
82.             Next sh
    
83.             wk.SaveAs ipath & fname & ".xls"
    
84.             wk.Close
    
85.         End With
    
86.     Next
    
87. Application.ScreenUpdating = True
    
88. MsgBox "成功生成 " & Mxi.Count & " 份索赔单，耗时 " & Format(Timer - t, "0.000") & " 秒！"
    
89. End Sub

复制代码

yayahzmeng

昨晚居然没有发成功，请测试一下

1. Sub autoT()
   
2. Application.ScreenUpdating = False
   
3. 
   
4.     Dim arr, brr, Mxi, Tongx, t, i&, j%, k%, a, b, facN
   
5.     Dim wb As Workbook, wk As Workbook
   
6.     Dim sh As Worksheet, ipath
   
7.     t = Timer
   
8.     ipath = ThisWorkbook.Path & "\索赔单"
   
9.     Set Mxi = CreateObject("scripting.dictionary")
   
10.     Set Tongx = CreateObject("scripting.dictionary")
    
11.     arr = Array("J4", "D5", "C17", "A17", "c4", "D8", "J8", "H10", "D10", "J10", "I21")
    
12.     brr = Array("I6", "J6", "I7")
    
13.     '清空标准表单
    
14.     For i = 0 To UBound(arr)
    
15.         Range(arr(i)) = ""
    
16.     Next
    
17.     For i = 0 To UBound(brr)
    
18.         Range(brr(i)) = ""
    
19.     Next
    
20.     Set wb = Workbooks.Open(ThisWorkbook.Path & "\索赔明细.xlsx")
    
21. 
    
22.         With ActiveSheet
    
23.         a = .Range("A2:I" & .[a1].End(4).Row)
    
24.         For i = 1 To UBound(a)
    
25.             For j = 2 To 9
    
26.                 Mxi(a(i, 1)) = Mxi(a(i, 1)) & a(i, j) & vbTab
    
27.             Next
    
28.         Next
    
29.         End With
    
30.         Erase a: wb.Close False: i = 1
    
31.         Set wb = Nothing
    
32.         
    
33.     Set wb = Workbooks.Open(ThisWorkbook.Path & "\标准通讯录.xls")
    
34.         With ActiveSheet
    
35.             a = .Range("D2:G" & .[d2].End(4).Row)
    
36.             For i = 1 To UBound(a)
    
37.                 Tongx(a(i, 1)) = a(i, 2) & vbTab & a(i, 3) & vbTab & a(i, 4)
    
38.             Next
    
39.         End With
    
40.         Erase a: wb.Close False
    
41.         Set wb = Nothing
    
42.    
    
43.     For i = 1 To Mxi.Count
    
44.         a = Split(Mxi(i), vbTab)
    
45.         With ActiveSheet
    
46.             For k = 0 To UBound(arr) Step 1
    
47.                 If k <= 7 Then
    
48.                     .Range(arr(k)) = a(k)
    
49.                 End If
    
50.                 If k = 8 Then .Range(arr(k)) = a(5)
    
51.                 If k = 9 Then .Range(arr(k)) = a(6)
    
52.                 If k = 10 Then .Range(arr(k)) = a(2)
    
53.             Next
    
54.             formN = Right(a(4), 6)
    
55.             Erase a
    
56.             facN = .Range(arr(1))
    
57.             b = Split(Tongx(facN), vbTab)
    
58.             For j = 0 To UBound(brr)
    
59.                 .Range(brr(j)) = "" & b(j)
    
60.             Next
    
61.             Erase b
    
62.             fname = formN & facN
    
63.             Set wk = Workbooks.Add
    
64.              .Copy before:=wk.Worksheets("sheet1")
    
65. 
    
66.             For Each sh In wk.Worksheets
    
67.                  If sh.Name Like "*Sheet*" Then
    
68.                     Application.DisplayAlerts = False
    
69.                     sh.Delete
    
70.                     Application.DisplayAlerts = True
    
71.                  End If
    
72.             Next sh
    
73.             wk.SaveAs ipath & fname & ".xls"
    
74.             wk.Close
    
75.         End With
    
76.     Next
    
77. Application.ScreenUpdating = True
    
78. MsgBox "成功生成 " & Mxi.Count & " 份索赔单，耗时 " & Format(Timer - t, "0.000") & " 秒！"
    
79. End Sub
    

复制代码

打开“标准表格.xlsm”，ctrl + p
测试了一下，900秒生成4000份，个人觉得速度不太令人满意，不知道其它大神有没有更快的保存工作簿的代码