I need to copy a specific range in multiple sheets and paste them on a final sheet

Viewed 54

There are 24 sheets in this workbook. I need to copy the same range from 23 sheets and paste them in a final sheet called "ALL SURVEY". Is there any way to code it in such a way that I don't need to write so much code as I did in the following macro?

Sheets("2").Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E2").*PasteSpecial xlPasteValues*
Sheets("3").Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E3").*PasteSpecial xlPasteValues*
Sheets("4").Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E4").*PasteSpecial xlPasteValues*
Sheets("5").Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E5").*PasteSpecial xlPasteValues*

It will be much appreciated if you help me get through this hard task Thank you

3 Answers

You can use a For...Next loop for this:

Sub Tester()
    Dim n As Long, c As Range
    
    Set c = ThisWorkbook.Sheets("ALL SURVEY").Range("E2") 'first destination cell
    'loop through sheets
    For n = 2 To 23
        'convert n to string to get the correct sheet
        ' Sheets("2") vs Sheets(2) - by sheet Name vs. Index
        With ThisWorkbook.Sheets(CStr(n)).Range("U3:X3") 
            c.Resize(.Rows.Count, .Columns.Count).Value = .Value 'set values
            Set c = c.Offset(1, 0) 'next destination
        End With
    Next n
End Sub

You can do something like this:

Sub copyPaste()

Dim survey_sheet As Worksheet, count As Long

count = 1 'start pasting from this row

For Each survey_sheet In ThisWorkbook.Sheets

    If survey_sheet.Name <> "ALL SURVEY" Then
        
        survey_sheet.Range("U3:X3").Copy
        Sheets("ALL SURVEY").Range("E" & count).PasteSpecial xlPasteValues
        count = count + 1
    
    End If
    
Next survey_sheet

End Sub

As you can see in the macro above, there is a loop For all the sheets in the Workbook. It will end when it has gone through every single one.

The If statement is to avoid copy/pasting in the final sheet ant the count variable is for pasting in the next empty row on "ALL SURVEY" sheet.

Copy Ranges by Rows

  • Adjust the values in the constants section. Pay attention to the Exceptions List. I added those two 'funny' names just to show that you have to separate them by the Delimiter with no spaces. The list can contain non-existing worksheet names, but it won't help, so remove them and add others if necessary.
  • You can resize the 'copy' range as you desire (e.g. U3:X5, Z7:AS13). The result will be each next range below the other (by rows).
  • Basically, the code will loop through all worksheets whose names are not in the Exceptions List and will write the values of the given range to 2D one-based arrays in an Array List. Then it will loop through the arrays of the Array List and copy the values to the resulting Data Array whose values will then be copied to the Destination Range.

The Code

Option Explicit

Sub copyByRows()
    
    Const dstName As String = "ALL SURVEY"
    Const dstFirst As String = "E2"
    Const srcRange As String = "U3:X3"
    Const Delimiter As String = ","
    Dim ExceptionsList As String
    ExceptionsList = dstName & Delimiter & "Sheet500,Sheet1000"
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim dst As Worksheet: Set dst = wb.Worksheets(dstName)
    Dim srCount As Long: srCount = dst.Range(srcRange).Rows.Count
    Dim cCount As Long: cCount = dst.Range(srcRange).Columns.Count
    
    Dim arl As Object: Set arl = CreateObject("System.Collections.ArrayList")
    Dim Exceptions() As String: Exceptions = Split(ExceptionsList, Delimiter)
    
    Dim ws As Worksheet
    For Each ws In wb.Worksheets
        If IsError(Application.Match(ws.Name, Exceptions, 0)) Then
            arl.Add ws.Range(srcRange).Value
        End If
    Next ws
    
    Dim Data As Variant: ReDim Data(1 To arl.Count * srCount, 1 To cCount)
    Dim Item As Variant
    Dim i As Long
    Dim j As Long
    Dim k As Long
    For Each Item In arl
        For i = 1 To srCount
            k = k + 1
            For j = 1 To cCount
                Data(k, j) = Item(i, j)
            Next j
        Next i
    Next Item
    
    dst.Range(dstFirst).Resize(k, cCount).Value = Data
    
End Sub
Related