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

Question

I have 2 excel files. First one is the source file “Practice_New.xlsx” and second is a mapping file “A_File.xlsx”. A_File is a mapping file which contains cell reference of the source file (“Practice_New.xlsx”) to the target file (I need to create this file, say “Practice_New_Output.xlsx”). I have written the below VBA code to achieve that but it's taking huge much time to complete. Data volume in the source excel is more than 500 rows sometime. Can anyone please help me to tune up this code to perform better? Also, Date values are displaying as number in the output file.

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

You just need to move the code to open and close the workbooks out of the loop.

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