設(shè)為首頁收藏本站Access中國

Office中國論壇/Access中國論壇

 找回密碼
 注冊

QQ登錄

只需一步，快速開始

返回列表 發(fā)新帖
查看: 2420|回復(fù): 2
打印 上一主題 下一主題

急救�。�！ VBA 批量導(dǎo)入和批量導(dǎo)出標(biāo)準(zhǔn)表格

[復(fù)制鏈接]
跳轉(zhuǎn)到指定樓層
1#
發(fā)表于 2016-9-4 19:21:40 | 只看該作者 回帖獎(jiǎng)勵(lì) |倒序?yàn)g覽 |閱讀模式
各位高手：
    最近手上有幾千行數(shù)據(jù)（見索賠明細(xì)），每一行代表對一個(gè)供應(yīng)商的索賠信息（包括供應(yīng)商名稱、原始金額、供應(yīng)商名稱、索賠單編號、索賠產(chǎn)品、數(shù)量、發(fā)生月份等），需要將索賠明細(xì)中每一行的信息對應(yīng)復(fù)制黏貼到標(biāo)準(zhǔn)表格對應(yīng)的陰影區(qū)域，由于數(shù)據(jù)量太大。而且是重復(fù)的動(dòng)作，不知道可以用VBA實(shí)現(xiàn)嗎？急用，萬分感謝
    其中標(biāo)準(zhǔn)表格中陰影區(qū)域的數(shù)據(jù)來源如下：
    GX2016090476 來源于 索賠明細(xì)中 索賠單編號
    2016-9-2     來源于 索賠明細(xì)中  制單日期
   黎明液壓有限公司  來源于 索賠明細(xì)中 供應(yīng)商名稱
    蔣經(jīng)理  來源于 標(biāo)準(zhǔn)通訊錄中 黎明液壓有限公司對應(yīng)的聯(lián)系人，如果標(biāo)準(zhǔn)通訊錄中未找到該供應(yīng)商名稱，那么聯(lián)系人、電話、傳真均空白，其他工作繼續(xù)進(jìn)行
      3775893399     來源于 標(biāo)準(zhǔn)通訊錄中蔣經(jīng)理對應(yīng)電話
       7732760       來源于 標(biāo)準(zhǔn)通訊錄中蔣經(jīng)理對應(yīng)傳真，如沒有就空著
     過濾器  來源于  索賠明細(xì)中 索賠產(chǎn)品
         13  來源于  索賠明細(xì)中 數(shù)量
    2016年8月  來源于 索賠明細(xì)中 發(fā)生月份
    230  來源于   索賠明細(xì)中    原始金額
  269.1  來源于    索賠明細(xì)中  索賠單金額

     希望將每一行轉(zhuǎn)化為索賠單之后，另存為excel表，保存在桌面上“索賠單”文件夾，且表格的名字命名方式為：索賠單編號后六位數(shù)字+供應(yīng)商名稱，本例子最后生成的excel名稱應(yīng)為“090476黎明液壓有限公司”。     

本帖子中包含更多資源

您需要 登錄 才可以下載或查看，沒有帳號？注冊

x
分享到:  QQ好友和群QQ好友和群 QQ空間QQ空間 騰訊微博騰訊微博 騰訊朋友騰訊朋友
收藏收藏1 分享分享 分享淘帖 訂閱訂閱
2#
發(fā)表于 2017-1-20 02:11:51 | 只看該作者
請測試一下！
3分半，生成200份索賠單，個(gè)人覺得不太滿意
  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.     '清空標(biāo)準(zhǔn)表單
  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 & "\索賠明細(xì).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("標(biāo)準(zhǔn)").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 & "\標(biāo)準(zhǔn)通訊錄.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 & " 份索賠單，耗時(shí) " & Format(Timer - t, "0.000") & " 秒！"
  89. End Sub
復(fù)制代碼

本帖子中包含更多資源

您需要 登錄 才可以下載或查看，沒有帳號？注冊

x
3#
發(fā)表于 2017-1-20 09:12:41 | 只看該作者
本帖最后由 yayahzmeng 于 2017-1-20 15:30 編輯

昨晚居然沒有發(fā)成功，請測試一下
  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.     '清空標(biāo)準(zhǔn)表單
  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 & "\索賠明細(xì).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 & "\標(biāo)準(zhǔn)通訊錄.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 & " 份索賠單，耗時(shí) " & Format(Timer - t, "0.000") & " 秒！"
  79. End Sub
復(fù)制代碼


打開“標(biāo)準(zhǔn)表格.xlsm”，ctrl + p
測試了一下，900秒生成4000份，個(gè)人覺得速度不太令人滿意，不知道其它大神有沒有更快的保存工作簿的代碼

本帖子中包含更多資源

您需要 登錄 才可以下載或查看，沒有帳號？注冊

x
您需要登錄后才可以回帖 登錄 | 注冊

本版積分規(guī)則

QQ|站長郵箱|小黑屋|手機(jī)版|Office中國/Access中國 ( 粵ICP備10043721號-1 )  

GMT+8, 2025-7-17 06:00 , Processed in 0.110947 second(s), 27 queries .

Powered by Discuz! X3.3

© 2001-2017 Comsenz Inc.

快速回復(fù) 返回頂部 返回列表