I would like to loop copy paste data from One Workbook to Another Workbook's sheets with same n-CodePudding

So I have some Workbooks (2020 & 2021). Each have 12 Sheets which are based on Month Name eg Jan, Feb, March.

So I would like to write a code to paste data from Sheet("Jan") to Sheet("Jan") and so on from the Workbook 2020 to Workbook 2021 in simple codes.

To do so I have written 25 Codes 12 to Copy and 12 to paste and one Master code to Run all of them.

Is there better alternative to Copy paste them by shortest easiest possible code.

Can I do it with loop. Match Sheets Name and Paste from One Workbook to Another.

Below is example of Code I have written.

Sub Master_Code()
Call_Jan_Copy
Call_Feb_Copy
Call_Mar_Copy
Call_Apr_Copy
Call_May_Copy
Call_Jun_Copy
Call_Jul_Copy
Call_Aug_Copy
Call_Sep_Copy
Call_Oct_Copy
Call_Nov_Copy
Call_Dec_Copy
End Sub


Sub Jan_Copy()'Code-1
Sheets("Jan").Select
ActiveSheet.Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Offset(1, 0).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Call Jan_Paste
End Sub


Sub Jan_Paste()'Code-2
Sheets("Jan").Select
ActiveSheet.Range("A1").Select
ActiveSheet.Range("A1048576").End(xlUp).Offset(1, 0).Select
ActiveCell.PasteSpecial xlPasteAll
Application.CutCopyMode = False
End Sub'

CodePudding user response：

Don't rely on ActiveSheet or ActiveWorkbook. Use references instead

Something like

Sub CopyMonths()
    Dim wbSrc As Workbook
    Dim wbDst As Workbook
    Dim wsSrc As Worksheet
    Dim wsDst As Worksheet
    
    Set wbSrc = Application.Workbooks("NameOfYourSourceBook.xlsx/m/b")  ' Update to your book name, including extension
    Set wbDst = Application.Workbooks("NameOfYourDestinationBook.xlsx/m/b") ' Update to your book name, including extension
    
    For Each wsSrc In wbSrc.Worksheets
        Set wsDst = wbDst.Worksheets(wsSrc.Name)
        
        wsSrc.UsedRange.Copy
        wsDst.Cells(1, 1).PasteSpecial xlPasteAll
    Next
End Sub

CodePudding user response：

Append Worksheet Data

Option Explicit

Sub AppendLastYear()
    
    Const sFilePath As String = "C:\Test\2020.xlsm"
    
    Dim dwb As Workbook: Set dwb = ThisWorkbook
    
    Dim swb As Workbook: Set swb = Workbooks.Open(sFilePath)
    
    Application.ScreenUpdating = False
    
    Dim sws As Worksheet
    Dim srg As Range
    Dim dws As Worksheet
    Dim dfCell As Range
    
    For Each dws In dwb.Worksheets
        Set dfCell = dws.Cells(dws.Rows.Count, "A").End(xlUp).Offset(1)
        Set sws = swb.Worksheets(dws.Name)
        With sws.Range("A1").CurrentRegion
            Set srg = .Resize(.Rows.Count - 1).Offset(1)
        End With
        srg.Copy dfCell
    Next dws
    
    swb.Close SaveChanges:=False
    
    Application.ScreenUpdating = True
    
    MsgBox "Last year appended.", vbInformation
    
End Sub