Copy paste data from multiple sheets onto one sheet

[Mr_Peter]

Hi all, please will someone help assist me with this VBA macro I am struggling to write. I have a workbook with multiple worksheets containing data, the aim of this VBA macro is to copy data from all the different worksheets into one worksheet that I will call "Historical", as a place to consolidate all the data gathered. So in the picture below, I need to copy the data from worksheet "Lesotho" and paste it onto the worksheet "Historical". The data that needs to be copied is Range("D2:E41"), the "Historical" worksheet will have all the headings in column "B" already.

Here is a picture of what I want it to look like after the data is copied from the worksheet "Lesotho" to "Historical".

I also need data from another worksheet copied and pasted below the data for "Lesotho" on the "Historical" worksheet, so in this case data from "Uganda" where the range is ("D2:E61") needs to be pasted below the data from "Lesotho" on the "Historical" worksheet, where it will look like this:

The data from "Uganda" needs to be pasted into Range("C42:D101") on the "Historical" worksheet, below the data from "Lesotho". The last part I am looking to do with this VBA macro is to have the macro copy paste data every new week, in the pictures posted the date is 6 November 2022, there will be another macro that hides columns "C" and "D". I now need this same copy paste macro to copy data from range ("F2:G61") on "Lesotho" and paste it after the data already on "Historical". This picture below is the "Lesotho" worksheet with columns "C" and "D" hidden.

Here is what I want it to look like after the data is copied onto the worksheet "Historical".

The data for range ("F2:G41") from worksheet "Lesotho" is pasted into range ("E2:F41") on the worksheet "Historical", the macro would also copy data from "Uganda" where columns "C" and "D" would be hidden, copying range ("F2:G61") from "Uganda" and pasting it to range ("E42:F101") on "Historical". Would it be possible to write this VBA macro? I am not sure on the limitations for Excel VBA, and it seems like this is a long macro to write since I am consolidating data from multiple worksheets into one worksheet, on top of one another where I am hiding columns in the other worksheets as well. Please and thank you in advance if anyone is able to assist me. Apologies for the long post as I am quite new to Excel VBA. Thank you again!

 

[sijpie]

If you can do it by hand you can do it with VBA.

But what does the code need to do? Go through the tables and copy those columns that have a planned and actual column for a date?
Or only copy (add) those columns that belong to a given date (for instance once every week, for the previous week)?

 

[Mr_Peter]

Hi sijpie, thank you for your response. I managed to solve my query after utilising the services of someone on fiverr. Here is the code for both macros below to give some context, the first macro that hides 2 columns to the right of "B3" then inserts a new column between the next 2 columns and adds a column at the end of the range. I realised that the VBA code is a lot more complex than I had hoped for.

VBA code for first macro that hides columns:

Sub program_macro1()
Dim last_col As Long
Dim actws As Worksheet
Application.ScreenUpdating = False
For i = 1 To ThisWorkbook.Sheets.Count
    Set actws = ThisWorkbook.Sheets(i)
    actws.Activate
    If actws.Name <> "Historical" And actws.Name <> "Historical_GHANA_SA" And actws.Visible = True Then
        last_col = actws.Cells(3, actws.Columns.Count).End(xlToLeft).Column
        For j = 3 To last_col
            If actws.Columns(j).Hidden = False Then
                col_vis = j
                Exit For
            End If
        Next j

        actws.Range(actws.Columns(col_vis), actws.Columns(col_vis + 1)).EntireColumn.Hidden = True
    actws.Columns(col_vis + 3).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
     actws.Cells(2, col_vis + 2).Value = "Planned"
     actws.Cells(2, col_vis + 3).Value = "Actuals"

    actws.Cells(3, col_vis + 2).Copy
    actws.Cells(3, col_vis + 3).PasteSpecial xlPasteValues
    Application.CutCopyMode = False

     last_col = actws.Cells(3, actws.Columns.Count).End(xlToLeft).Column

     actws.Columns(last_col).Copy
     actws.Columns(last_col + 1).Select
     actws.Paste
    Application.CutCopyMode = False
    actws.Cells(1, 1).Select
    actws.Range(actws.Cells(4, last_col + 1), actws.Cells(40000, last_col + 1)).ClearContents

    End If
Next i
Application.ScreenUpdating = True
MsgBox "Process Completed!", vbInformation
End Sub

VBA code for second macro that copies data from tabs:

Sub program_macro2()
Dim last_col As Long
Dim actws As Worksheet, histws As Worksheet, start_row As Long, new_col As Long, last_row As Long
Application.ScreenUpdating = False
For i = 1 To ThisWorkbook.Sheets.Count
    Set actws = ThisWorkbook.Sheets(i)
        actws.Activate
    If actws.Name <> "Historical" And actws.Name <> "Historical_GHANA_SA" And actws.Visible = True Then
        If actws.Name <> "Ghana" And actws.Name <> "South Africa" Then
            Set histws = ThisWorkbook.Sheets("Historical")
        Else
            Set histws = ThisWorkbook.Sheets("Historical_GHANA_SA")
        End If
            
            
            start_row = 0
            On Error Resume Next
            start_row = Application.Match(actws.Name, histws.Columns(2), 0)
            On Error GoTo 0
            new_col = histws.Cells(start_row, histws.Columns.Count).End(xlToLeft).Column + 1
            
            If start_row > 0 Then
                    last_col = actws.Cells(3, actws.Columns.Count).End(xlToLeft).Column
                    last_row = actws.Cells(actws.Rows.Count, 2).End(xlUp).Row
                    For j = 3 To last_col
                        If actws.Columns(j).Hidden = False Then
                            col_vis = j
                            Exit For
                        End If
                    Next j
                
                    'copy paste data
                    actws.Range(actws.Cells(2, col_vis), actws.Cells(last_row, col_vis + 1)).Copy
                    histws.Activate
                    histws.Cells(start_row, new_col).Select
                    
                    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
                    , SkipBlanks:=False, Transpose:=False
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
                     Application.CutCopyMode = False
                     
                         histws.Range(histws.Columns(new_col), histws.Columns(new_col + 1)).EntireColumn.AutoFit
            End If
    
    
    End If
Next i
Application.ScreenUpdating = True
MsgBox "Process Completed!", vbInformation
End Sub

Thanks so much for your reply, my questions have been solved for now but I will be sure to ask if I have any more queries in the future!