Snasui Excel Forum

Code: Select all

Sub CollectData()
    Dim ws As Worksheet
    Dim r As Range
    Dim rTarget As Range
    Application.ScreenUpdating = False
    For Each ws In Worksheets
        If ws.Name <> "Data" Then
            With Sheets("Data")
                Set rTarget = .Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            End With
            Set r = ws.Range("A2", ws.Range("A" & Rows.Count).End(xlUp))
              r.SpecialCells(xlCellTypeConstants).EntireRow.Copy
              rTarget.PasteSpecial xlPasteValues
        End If
    Next ws
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Code: Select all

Sub CollectData()
    Dim ws As Worksheet
    Dim rTarget As Range
    Dim r, rAll, Lrw As Integer
    Dim Vr, v As Variant
    Application.ScreenUpdating = False
    For Each ws In Worksheets
        If ws.Name <> "Data" Then
            With Sheets("Data")
                Set rTarget = .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0)
                 Lrw = .Cells(.Rows.Count, "f").End(xlUp).Row
            End With
            rAll = ws.Range("k" & ws.Rows.Count).End(xlUp).Row
            Vr = Array("Booking", "Waiting", "Mail / New patient")
            For r = 2 To rAll
            For Each v In Vr
               If ws.Cells(r, 11) = v Then
                              ws.Cells(r, 11).Offset(, -10).Resize(, 18).Copy
                 Sheets("Data").Cells(Lrw, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End If
        Next v
        Next r
        End If
    Next ws
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub