1: 2: 3: 4: 5: 6: 7: 8: 9: 10: 11: 12: 13: 14: 15: 16: 17: 18: 19: 20: 21: 22: 23: 24:
Sub test() Dim wksPasteTo As Worksheet Dim rngPasteTo As Range Dim sht As Worksheet Worksheets.Add , Sheets(Worksheets.Count) ActiveSheet.Name = "FRUIT" Set wksPasteTo = ActiveWorkbook.Sheets("FRUIT") Set rngPasteTo = wksPasteTo.Range("a3") For Each sht In ThisWorkbook.Worksheets If sht.Name <> "FRUIT" Then sht.Range("A1:I400").Copy Do Until rngPasteTo = "" Set rngPasteTo = rngPasteTo.Offset(1) Loop wksPasteTo.Paste rngPasteTo Else End If Next sht End Sub