VBA to loop through worksheets with sheet names in cells

[Godwin117]

I have this excel worksheet that I'm trying automate most of what I'm doing however I feel this is a little too advanced for me. I have the sheet names in cells(B2:B61). It will copy and paste data from D:I with the row that the sheet name is in and at the bottom of that sheet after the last row with data it will paste the copied data. An example is below. The main worksheet is called "Main".

On worksheet "Main" B2 is "MTP" the data is from D2:I2. Copy D2:I2 and go to worksheet("MTP") and paste underneath the previous data ("A"&lastrow). Go back to worksheet("Main"). B3 is "RENN" the data is from D3:I3. Copy D3:I3 and go to worksheet("RENN") and paste underneath the previous data ("A"&lastrow). Loop through all worksheets(B2:B61). Once complete Worksheet("Main").Select. Hopefully, this spells out what I'm looking for and any help would be greatly appreciated.

 

[vcoolio]

Hello Godwin,

If I've understood you correctly, this may work:-

Option Explicit
Sub TransferData()

        Dim ar As Variant, i As Long
        Dim wsM As Worksheet, wsA As Worksheet
        Set wsM = Sheets("Main")
        ar = Array("MTP", "RENN", "ABC", "XYZ") '---->Add your actual worksheet names to the array.

Application.ScreenUpdating = False

        For i = 0 To UBound(ar)
           Set wsA = Sheets(CStr(ar(i)))
                With wsM.[B1].CurrentRegion
                        .AutoFilter 1, ar(i)
                        Range(.Offset(1, 2), .Offset(1, 7)).Copy wsA.Range("A" & Rows.Count).End(3)(2)
                        .AutoFilter
                End With
                
                wsA.Columns.AutoFit
        Next i

Application.ScreenUpdating = True

End Sub

Please note that I've assumed the following:-
- You are not using Column A in the "Main" worksheet.
- In all worksheets, Row1 has headings with data commencing in Row2.

I don't know what you have in mind for Column C in the "Main" worksheet.

I hope that this helps.

Cheerio,
vcoolio.

 

[Godwin117]

Hello Godwin,

If I've understood you correctly, this may work:-

Option Explicit
Sub TransferData()

        Dim ar As Variant, i As Long
        Dim wsM As Worksheet, wsA As Worksheet
        Set wsM = Sheets("Main")
        ar = Array("MTP", "RENN", "ABC", "XYZ") '---->Add your actual worksheet names to the array.

Application.ScreenUpdating = False

        For i = 0 To UBound(ar)
           Set wsA = Sheets(CStr(ar(i)))
                With wsM.[B1].CurrentRegion
                        .AutoFilter 1, ar(i)
                        Range(.Offset(1, 2), .Offset(1, 7)).Copy wsA.Range("A" & Rows.Count).End(3)(2)
                        .AutoFilter
                End With
               
                wsA.Columns.AutoFit
        Next i

Application.ScreenUpdating = True

End Sub

Please note that I've assumed the following:-
- You are not using Column A in the "Main" worksheet.
- In all worksheets, Row1 has headings with data commencing in Row2.

I don't know what you have in mind for Column C in the "Main" worksheet.

I hope that this helps.

Cheerio,
vcoolio.

Thank you for your quick response. For the array, since the sheet names change frequently would I be able to use the cells instead of typing out each sheet name.
Also when I copy and paste the code it is giving me a "subscript out of range" at the 'Set wsA = Sheets(CStr(ar(i)))'.

 

[vcoolio]

Hello Godwin,

The best thing to do at this point is for you to upload a sample of your workbook for us to test with. Upload the sample to a free file sharing site such as WeTransfer or Drop Box then post the link to your file back here. Make sure that the sample is an exact replica of your actual workbook and if your data is sensitive, then please use dummy data.

Cheerio,
vcoolio.

 

[Godwin117]

Hello Godwin,

The best thing to do at this point is for you to upload a sample of your workbook for us to test with. Upload the sample to a free file sharing site such as WeTransfer or Drop Box then post the link to your file back here. Make sure that the sample is an exact replica of your actual workbook and if your data is sensitive, then please use dummy data.

Cheerio,
vcoolio.

The link is Stocks test.xlsm
Hopefully this gives a better idea of what I'm trying to do.

 

[vcoolio]

Hello Godwin,

"subscript out of range" at the 'Set wsA = Sheets(CStr(ar(i)))'.

That error usually means that certain worksheets can't be found (incorrect spelling, punctuation etc.) or don't exist. Those two sheets you have placed in the array in the code module do not exist in your sample.

Anyway, I'll have a look at this tomorrow for you.

Cheerio,
vcoolio.

 

[Godwin117]

Hello Godwin,



That error usually means that certain worksheets can't be found (incorrect spelling, punctuation etc.) or don't exist. Those two sheets you have placed in the array in the code module do not exist in your sample.

Anyway, I'll have a look at this tomorrow for you.

Cheerio,
vcoolio.

Ok thank you, when I do add sheets that exis it works, however its not copying data from the main sheet and pasting it underneath all of the data in the sheet.

 

[vcoolio]

Hello Godwin,

Something else we need to clear up.
You need the data from Columns D:I (six columns) transferred to the destination sheets from the Main sheet. However, the area in the destination sheets where the data is to go has seven columns. Does this mean that you need Column F (Adj Close) in the destination sheets left blank?

Cheerio,
vcoolio.

 

[Godwin117]

Hello Godwin,

Something else we need to clear up.
You need the data from Columns D:I (six columns) transferred to the destination sheets from the Main sheet. However, the area in the destination sheets where the data is to go has seven columns. Does this mean that you need Column F (Adj Close) in the destination sheets left blank?

Cheerio,
vcoolio.

That is correct or it can have the same information as the close column, whichever is easier.

 

[vcoolio]

Hello Godwin,

Two things that you must do first:-
1) Unhide Columns A and B in the "Main" sheet.
2) Place headings in A1 and B1, even if it just a single letter.

Following are two codes which will do the task for you. The second code is some 20%-30% faster and may suit you better:-

Option Explicit

Sub TransferData()

            Dim i As Long, x As Long, nrow As Long
            Dim clArr As Variant: clArr = Array(4, 5, 6, 7, 8, 9)
            Dim pArr As Variant: pArr = Array("A", "B", "C", "D", "E", "G")
            Dim wsM As Worksheet: Set wsM = Sheets("Main")
            Dim ar As Variant: ar = wsM.Range("B2", wsM.Range("B" & wsM.Rows.Count).End(xlUp))

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

            For i = 1 To UBound(ar)
                    nrow = Sheets(ar(i, 1)).Cells(Rows.Count, 1).End(xlUp).Row + 1
                    For x = LBound(clArr) To UBound(clArr)
                            With wsM.[A1].CurrentRegion
                                    .AutoFilter 2, ar(i, 1)
                                    .Columns(clArr(x)).Offset(1).Copy Sheets(ar(i, 1)).Range(pArr(x) & nrow)
                                    .AutoFilter
                            End With
                    Next x
            Next i

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Option Explicit
Sub TransferData2()

            Dim Data, Dict As Object, i As Long
            Dim wsM As Worksheet: Set wsM = Sheets("Main")

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

            Set Dict = CreateObject("Scripting.Dictionary")
            With wsM.Cells(1).CurrentRegion
                    Data = .Value
                    For i = 2 To UBound(Data)
                                If Data(i, 2) <> "" Then
                                If Not Dict.exists(Data(i, 2)) Then
                                Dict.Add Data(i, 2), 1
                                .AutoFilter 2, Data(i, 2)
                                With .Offset(1)
                                        .Columns("D:H").Copy Sheets(Data(i, 2)).Range("A" & Rows.Count).End(3)(2)
                                        .Columns("I").Copy Sheets(Data(i, 2)).Range("G" & Rows.Count).End(3)(2)
                                End With
                                .AutoFilter
                                End If
                          End If
                    Next i
            End With

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Both codes have been tested in the sample workbook that you supplied and both work well.

Please note that the second code is not my work. A fellow Volunteer (Sintek), who only visits another forum solely, took interest in your query and, through me, offered up the code for you to test with.

I hope that this helps.

Cheerio,
vcoolio.