Copy Range Based on Sheet Name VBA

[mdonovan890]

i'm New VBA and Marcos and am hoping someone can help. I have workbook with 50 plus sheets and I am trying to create a Macro that will copy the same range of cells on all sheets that have "Box" in the in the name and copy it to a Master Sheet in the same workbook with the originating sheet name shown in column J.


The issue is that this code copies all sheets within the workbook, the source column does not populate correctly and none of the formatting is copied. I am using Excel 2016 any help would be greatly appreciated.

After a lot of searching, this is what I have so far:

Public Sub m()
Dim lRow As Long
Dim sh As Worksheet
Dim shArc As Worksheet
Set shArc = ThisWorkbook.Worksheets("Archive")
For Each sh In ThisWorkbook.Worksheets
Select Case sh.Name
Case Is <> "Archive"
lRow = shArc.Range("A" & Rows.Count).End(xlUp).Row + 1
sh.Range("A2:I110").Copy
shArc.Range("A" & lRow).PasteSpecial
DestSh.Cells(Last + 1, "J").Resize(CopyRng.Rows.Count).Value = sh.Name
End Select
Next
Application.CutCopyMode = False
Set shArc = Nothing
Set sh = Nothing

 

[alansidman]

Here is an untested modifcation

Sub box()
    Dim sh As Worksheet
    Dim lRow As Long
    Dim shArc As Worksheet
    Set shArc = ThisWorkbook.Worksheets("Archive")


    For Each sh In Worksheets
        If InStr(sh.Name, "Box") > 0 Then
            lRow = shArc.Range("A" & Rows.Count).End(xlUp).Row + 1
            sh.Range("A2:I110").Copy
            shArc.Range("A" & lRow).PasteSpecial
            DestSh.Cells(Last + 1, "J").Resize(CopyRng.Rows.Count).Value = sh.Name
        End If
    Next ws
    Application.CutCopyMode = False
    MsgBox "Complete"


End Sub

Post back with issues or success story

 

[NdNoviceHlp]

Not sure if I'm clear on all your requirements but U can trial...

Public Sub m()
Dim lRow As Double
Dim sh As Worksheet
Dim shArc As Worksheet
Set shArc = ThisWorkbook.Worksheets("Archive")
For Each sh In ThisWorkbook.Worksheets
If InStr("Box", sh.Name) Then
lRow = shArc.Range("A" & Rows.Count).End(xlUp).Row
sh.Range("A2:I110").Copy
shArc.Range("A" & lRow + 1).PasteSpecial xlPasteValuesAndNumberFormats
shArc.Range("J" & lRow + 1) = sh.Name
Application.CutCopyMode = False
End If
Next
End Sub

HTH. Dave
ps. please use code tags

 

[mdonovan890]

c

 

[mdonovan890]

Thank you for your assistance, when i tried running your code, it returned with an "Invalid Next Control Variable Reference" Error, do you happen to know what changes I need to make to correct this?

 

[mdonovan890]

Here is an untested modifcation

Thank you for your assistance, when i tried running your code, it returned with an "Invalid Next Control Variable Reference" Error, do you happen to know what changes I need to make to correct this?

 

[alansidman]

Oops. Change Next ws to Next sh