Snasui Excel Forum

Code: Select all

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