I have a 12 sheets with information within them. Certain information I want to collate from each sheet onto one sheet.
So,
I first of all find out how many rows I am dealing with, then I want to copy the first two columns into another sheet (Results).
Now I can get the first column to copy across from each sheet but a cannot workout what im doing wrong to get the second column copied aswell.
Sub loopMe()
Dim Jan As Worksheet, Feb As Worksheet, Mar As Worksheet, Apr As Worksheet, May As Worksheet, Jun As Worksheet
Dim Jul As Worksheet, Aug As Worksheet, Sep As Worksheet, October As Worksheet, Nov As Worksheet, Dec As Worksheet
Dim LstR As Long, rngJan As Range, c As Range, rngFeb As Range, rngMar As Range, rngApr As Range
Dim rngMay As Range, rngJun As Range, rngJul As Range, rngAug As Range, rngSep As Range, rngOctober As Range
Dim rngNov As Range, rngDec As Range
Set Jan = Sheets("January") 'set the sheet to loop
With Jan 'do something with the sheet
LstR = .Cells(.Rows.Count, "A").End(xlUp).Row 'find last row
Set rngJan = .Range("A2:B" & LstR) 'set range to loop
End With
Set Feb = Sheets("February") 'set the sheet to paste
With Feb 'do something with the sheet
LstR = .Cells(.Rows.Count, "A").End(xlUp).Row 'find last row
Set rngFeb = .Range("A2:B" & LstR) 'set range to loop
End With
' The above should set the range of data in each sheet (I hope) ' Then I run the following
For Each y In rngJan
Worksheets("Results").Range("A65536").End(xlUp).Offset(1, 0).Value = y.Value
Next y
For Each y In rngFeb
Worksheets("Results").Range("A65536").End(xlUp).Offset(1, 0).Value = y.Value
Next y
The information I need are stored in columns A & B so they are what im trying to copy across.
Can anyone help??
Try this:
First you only want to loop through column A.
Then set the ranges to two columns, the source is easy as declaring the range with y and y.offset. The target use resize(,2).
Sub loopMe()
Dim Jan As Worksheet, Feb As Worksheet, Mar As Worksheet, Apr As Worksheet, May As Worksheet, Jun As Worksheet
Dim Jul As Worksheet, Aug As Worksheet, Sep As Worksheet, October As Worksheet, Nov As Worksheet, Dec As Worksheet
Dim LstR As Long, rngJan As Range, c As Range, rngFeb As Range, rngMar As Range, rngApr As Range
Dim rngMay As Range, rngJun As Range, rngJul As Range, rngAug As Range, rngSep As Range, rngOctober As Range
Dim rngNov As Range, rngDec As Range
Set Jan = Sheets("January") 'set the sheet to loop
With Jan 'do something with the sheet
LstR = .Cells(.Rows.Count, "A").End(xlUp).Row 'find last row
Set rngJan = .Range("A2:A" & LstR) 'set range to loop
End With
Set Feb = Sheets("February") 'set the sheet to paste
With Feb 'do something with the sheet
LstR = .Cells(.Rows.Count, "A").End(xlUp).Row 'find last row
Set rngFeb = .Range("A2:A" & LstR) 'set range to loop
End With
' The above should set the range of data in each sheet (I hope) ' Then I run the following
For Each y In rngJan
Worksheets("Results").Range("A65536").End(xlUp).Offset(1, 0).resize(,2).Value = Range(y, y.Offset(, 1)).Value
Next y
For Each y In rngFeb
Worksheets("Results").Range("A65536").End(xlUp).Offset(1, 0).resize(,2).Value = Range(y, y.Offset(, 1)).Value
Next y
End Sub
Try this code for an efficient use of the For...Next
statement, avoiding the excessive use of object variables. It clears previous data before proceeding to copy data, also includes an error handling in case the worksheet was deleted or it's expected name changed. Tried to make it self explanatory with comments in the code, nevertheless do let me know of any question you may have.
Sub Copy_Months_Data()
Const kRowIni As Byte = 2 'Constant to hold the starting row, easy to update if required
Dim aMonths As Variant
aMonths = Array("January", "February", "March", "April", _
"May", "June", "July", "August", _
"September", "October", "November", "December")
Dim WshSrc As Worksheet, WshTrg As Worksheet
Dim rSrc As Range
Dim lRowLst As Long, lRowNxt As Long
Dim vItm As Variant
On Error GoTo ErrHdlr
Application.ScreenUpdating = 0
Application.EnableEvents = 0
With ThisWorkbook 'Procedure is resident in data workbook
'With Workbooks(WbkName) 'Procedure is no resident in data workbook
Rem Set & Prepare Target Worksheet - Results
vItm = "Results"
Set WshTrg = .Sheets(vItm) 'Change sheet name as required
With WshTrg
Application.Goto .Cells(1), 1
Rem Clear Prior Data
.Columns("A:B").ClearContents
lRowNxt = kRowIni
End With
For Each vItm In aMonths
Rem Set Source Worksheet - Each month
Set WshSrc = .Sheets(vItm)
With WshSrc
Rem Set Last Row for Columns A & B
lRowLst = .Cells(.Rows.Count, "A").End(xlUp).Row
If .Cells(.Rows.Count, "B").End(xlUp).Row > lRowLst Then _
lRowLst = .Cells(.Rows.Count, "B").End(xlUp).Row
Set rSrc = .Range(.Cells(kRowIni, 1), .Cells(lRowLst, 2))
End With
Rem Copy Range Values to Target Worksheet
With rSrc
WshTrg.Cells(lRowNxt, 1).Resize(.Rows.Count, .Columns.Count).Value = .Value2
lRowNxt = lRowNxt + .Rows.Count
End With
Next: End With
Application.ScreenUpdating = 1
Application.EnableEvents = 1
Exit Sub
ErrHdlr:
MsgBox prompt:="Process failed while processing worksheet """ & vItm & """ due to: " & vbLf & _
vbTab & "Err: " & Err.Number & vbLf & _
vbTab & "Dsc: " & Err.Description, _
Buttons:=vbCritical + vbApplicationModal, _
Title:="Copy Months Data"
Application.ScreenUpdating = 1
Application.EnableEvents = 1
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.