Macro to combine sheets with same tab colour

[siriusblack1106]

I have a workbook with multiple sheets, all colour coded.

I need to copy a certain region from each sheet with the same tab colour and paste it in a new sheet.

This is the code i've been using. But instead of copying data from each sheet, the data from the first sheet in the cycle alone is being copied and pasted repeatedly.


The code i'm using is :


Option Explicit


Sub mdata()
Dim name As String
Dim ws As Worksheet
Dim i As Integer
Dim row As Integer
Dim r As Integer
Dim column As Variant
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range

With Application
.ScreenUpdating = False
.EnableEvents = False
End With


Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Merge").Delete
On Error GoTo 0
Application.DisplayAlerts = True

Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.name = "Merge"

For Each sh In Worksheets
If sh.Tab.ColorIndex = 33 Then

Last = LastRow(DestSh)
With sh
Cells.Find(What:="DATE", After:=ActiveCell, LookIn:=xlValues, Lookat _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
End With
row = ActiveCell.row
column = ActiveCell.column
Set CopyRng = ActiveSheet.Range(Cells(row, column), Cells(row + 32, column + 30))
CopyRng.Copy
With DestSh.Cells(Last + 1, 1)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With


End If
Next sh





End Sub





Here, lastrow() is a function to find out the first empty row in a worksheet.

 

[Warship]

Very rarely do have to select/active sheets and ranges
try:

Sub mdata()
    '/////////////////////////////
    'using reserved words as variables is not good practice
        'Dim name As String
        'Dim column As Variant
        'Dim row As Integer
    '/////////////////////////////
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim CopyRng As Range
    Dim fnd As Range
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("Merge").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    
    Set DestSh = ActiveWorkbook.Worksheets.Add(Sheets(1))
    DestSh.Name = "Merge"
    
    For Each sh In Worksheets
        If sh.Tab.ColorIndex = 40 Then 'change 40 as needed
            Set fnd = sh.Cells.Find(What:="DATE", After:=ActiveCell, LookIn:=xlValues, Lookat _
                    :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
                    False, SearchFormat:=False)
            If Not fnd Is Nothing Then
                Set CopyRng = fnd.Resize(33, 31)
                CopyRng.Copy
                With DestSh.Cells(LastRow(DestSh) + 1, 1)
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                End With
            End If
        End If
    Next sh
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub