我需要在多张纸上复制特定范围并将它们粘贴到最后一张纸上

Question

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

Answer 1

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

Answer 2

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.

Answer 3

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 (eg 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