复制大数据的vba代码

Question

我使用以下代码将某些单元格从一个工作簿处理到另一个工作簿，但问题是我必须使用差异数据重复此代码，因为我有太多工作簿，当我尝试复制它们时，我收到一条错误消息，例如内存不足或者程序太大 有没有一种方法可以更轻松、更快地将这些数据从主工作簿复制到所有工作簿和文件

代码是：

Sub copy_paste1()
Dim wkb1 As Workbook
Dim sht1 As Worksheet
Dim wkb2 As Workbook
Dim sht2 As Worksheet

Application.ScreenUpdating = False 
Set wkb1 = Workbooks("info.xlsm") 



Set wkb2 = Workbooks.Open("D:\work\old server\Cards Tests\New folder\data\1-xxxxxxx.xlsm") 
Set sht1 = Workbooks("info.xlsm").Worksheets("Sheet2") 

Set sht2 = Workbooks("1-xxxxxxx.xlsm").Worksheets("Sheet1")
sht1.Range("a2").copy
sht2.Range("m4").PasteSpecial Paste:=xlValue, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wkb2.Close True

Application.CutCopyMode = False

Application.ScreenUpdating = False


Set wkb2 = Workbooks.Open("D:\work\old server\Cards Tests\New folder\data\1043-xxxxxxx.xlsm") 
Set sht1 = Workbooks("info.xlsm").Worksheets("Sheet2") 

Set sht2 = Workbooks("1043-xxxxxxx.xlsm").Worksheets("Sheet1")
sht1.Range("a52").copy
sht2.Range("m4").PasteSpecial Paste:=xlValue, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wkb2.Close True

Application.CutCopyMode = False

Application.ScreenUpdating = False


Set wkb2 = Workbooks.Open("D:\work\old server\Cards Tests\New folder\data\1044-xxxxxxx.xlsm") 
Set sht1 = Workbooks("info.xlsm").Worksheets("Sheet2") 

Set sht2 = Workbooks("1044-xxxxxxx.xlsm").Worksheets("Sheet1")
sht1.Range("a53").copy
sht2.Range("m4").PasteSpecial Paste:=xlValue, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wkb2.Close True

Application.CutCopyMode = False

Application.ScreenUpdating = False
end sub

Answer 1

我们在处理大量数据集（即csv，accdb，跨平台等）时也有类似的情况，为了提高效率，我肯定会限制打开，关闭，保存操作，避免不必要的计算（我主要是关闭 calc），我确实考虑了错误处理以避免运行时错误，但缺点是在处理批量的过程中很难检查。正如您提到的作为代码的一部分，下面的一些结构可能会有所帮助。

Sub copy_paste1()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    
    Dim wkb1 As Workbook
    Dim sht1 As Worksheet
    Dim wkb2 As Workbook
    Dim sht2 As Worksheet
    
    Set wkb1 = Workbooks("info.xlsm")
    Set sht1 = wkb1.Worksheets("Sheet2")
    
    Dim targetFile As Variant
    Dim targetFiles As Variant
    Dim filePath As String
    
    targetFiles = sht1.Range("A1:A4000").Value
    
    filePath = "D:\work\old server\Cards Tests\New folder\data\"
    
    For Each targetFile In targetFiles
        If targetFile <> "" Then
            Set wkb2 = Workbooks.Open(filePath & targetFile, ReadOnly:=True)
            Set sht2 = wkb2.Worksheets("Sheet1")
            
            CopyPasteData sht1, sht2
            
            wkb2.Close SaveChanges:=False
        End If
    Next targetFile
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True

End Sub

Sub CopyPasteData(srcSht As Worksheet, dstSht As Worksheet)
    Dim srcRng As Range
    Dim dstRng As Range
    
    Set srcRng = srcSht.Range("A2")
    Set dstRng = dstSht.Range("M4")
    
    dstRng.Value2 = srcRng.Value2

End Sub