VBA复制粘贴循环 - 性能问题

Question

我有2个excel文件。第一个是源文件“Practice_New.xlsx”，第二个是映射文件“A_File.xlsx”。 A_File是一个映射文件，它包含源文件（“Practice_New.xlsx”）到目标文件的单元格引用（我需要创建此文件，比如说“Practice_New_Output.xlsx”）。我已经编写了下面的VBA代码来实现这一目标，但它需要花费大量时间才能完成。源excel中的数据量有时超过500行。任何人都可以帮我调整一下这段代码来表现更好吗？此外，日期值在输出文件中显示为数字。

Sub COPYCELL()

Dim wbk As Workbook

Dim x%

Application.DisplayAlerts = False

strParamFile = "C:\Users\rezaul.hasan\Desktop\Practice\A_FILE.xlsx" 

Workbooks.Open Filename:="C:\ Important\A_FILE.xlsx"

Sheets("Sheet1").Select

TargetFilename = Range("G2").Value

SourceFilename = Range("A2").Value

SourceTabName = Range("B2").Value

Set wbkt = Workbooks.Add

wbkt.SaveAs Filename:=" C:\ Important \" & TargetFilename & ".xlsx", FileFormat:=51

wbkt.Close

strFirstFile = " C:\ Important \" & SourceFilename & ".xlsx" 'Take the source excel

strSecondFile = " C:\ Important \" & TargetFilename & ".xlsx" 'take the target excel

Set wbkM = Workbooks.Open(strParamFile)

Set sh1 = Sheets("Sheet1")

lr = Range("C" & Rows.Count).End(xlUp).Row

For x = 2 To lr

Source = sh1.Range("C" & x).Value

Target1 = sh1.Range("E" & x).Value

Target2 = sh1.Range("F" & x).Value

Set wbkS = Workbooks.Open(strFirstFile)

With wbkS.Sheets(SourceTabName)

   .Range(Source).Copy

End With

Set wbk = Workbooks.Open(strSecondFile)

With wbk.Sheets("Sheet1")

.Range(Target1, Target2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

End With

wbk.Save

wbk.Close

wbkS.Close

Next

wbkM.Close

End Sub

A_File

Practice_New

Answer 1

您只需移动代码即可打开和关闭循环中的工作簿。

Sub COPYCELL2()
    Application.ScreenUpdating = False
    Dim x As Long
    Dim SourceTabName As String, Source As String, Target1 As String, Target2 As String

    Dim MapWB As Workbook, SourceWB As Workbook, TargetWB As Workbook

    Set MapWB = Workbooks.Open("C:\Users\rezaul.hasan\Desktop\Practice\A_FILE.xlsx")
    With MapWB.Worksheets("Sheet1")
        Set SourceWB = Workbooks.Open("C:\ Important \" & .Range("A2").Value)
        Set TargetWB = Workbooks.Add
        TargetWB.SaveAs Filename:="C:\ Important \" & .Range("G2").Value & ".xlsx", FileFormat:=51

        SourceTabName = .Range("B2").Value

        For x = 2 To .Range("C" & .Rows.Count).End(xlUp).Row
            Source = .Range("C" & x).Value
            Target1 = .Range("E" & x).Value
            Target2 = .Range("F" & x).Value
            SourceWB.Sheets(SourceTabName).Range(Source).Copy
            TargetWB.Sheets("Sheet1").Range(Target1, Target2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Next
    End With

    MapWB.Close SaveChanges:=False
    SourceWB.Close SaveChanges:=False
    TargetWB.Close SaveChanges:=True
    Application.ScreenUpdating = True
End Sub

Practice_New_Output.xlsx