Office中国论坛/Access中国论坛

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

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

作者: yayahzmeng    时间: 2017-1-20 02:11
请测试一下！
3分半，生成200份索赔单，个人觉得不太满意
  1. Sub autoT()
  2. Application.ScreenUpdating = False

  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")

  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    时间: 2017-1-20 09:12
本帖最后由 yayahzmeng 于 2017-1-20 15:30 编辑

昨晚居然没有发成功，请测试一下
  1. Sub autoT()
  2. Application.ScreenUpdating = False

  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")

  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")

  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份，个人觉得速度不太令人满意，不知道其它大神有没有更快的保存工作簿的代码




欢迎光临 Office中国论坛/Access中国论坛 (http://www.office-cn.net/) Powered by Discuz! X3.3