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
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.
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.U3:X5
, Z7:AS13
). The result will be each next range below the other (by rows).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
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.