I have a small macro that is supposed to copy/paste data from sheet 1 in Book1 to a fresh workbook (Book2). After that, I want it to loop through the rest of the worksheets from Book1 and copy/paste into Book2 but without the headers.
The macro below completes the first step but then continues to copy/pastes the records in sheet 1 every time instead of switching worksheets to copy/paste new data.
Sub CopyData()
' Copy A:D from all sheets to template
Dim ws As Worksheet
Dim sheetIndex As Integer
sheetIndex = 1
'First Sheet pulls in headers and data
Windows("Book1.xlsx").Activate
Sheets(1).Select
Range("A1:D" & Cells(Rows.Count, "C").End(xlUp).Row).Copy
Windows("Book2.xlsm").Activate
ActiveSheet.Paste
Windows("Book1.xlsx").Activate
'Every other worksheet only copies over data
For Each ws In ActiveWorkbook.Worksheets
If ws.Index <> 1 Then
Windows("Book1.xlsx").Activate
Range("A2:D" & Cells(Rows.Count, "C").End(xlUp).Row).Copy
Windows("Book2.xlsm").Activate
Range("A1").End(xlDown).Offset(1).Select
ActiveSheet.Paste
End If
sheetIndex = sheetIndex + 1
Next ws
End Sub
I'm not too experienced so I apologize if the code above isn't optimized. Thanks in advance for your help!
Quick and very dirty solution:
For Each ws In ActiveWorkbook.Worksheets
ws.Activate
'rest of the code
Next ws
It would be much better, if you assign the workbook to a variable and loop through the worksheets, without using Activate and Select.
To achieve something like this, it is important that you know how to initialize workbooks and sheets. Please find time to study how to initialize objects in vba because this will help you in the future.
Sub CopyData()
' Copy A:D from all sheets to template
Dim ws As Worksheet
Dim sheetIndex As Integer
Dim wbBook1 As Workbook, wbBook2 As Workbook
sheetIndex = 1
'First Sheet pulls in headers and data
Set wbBook1 = ThisWorkbook 'The Workbook where we will copy the data; This contains the macro
Windows("Book2.xlsx").Activate 'Because we don't know the book name we will just activate it to initialize
'the second workbook where we will copy our data from Book1
Set wbBook2 = ActiveWorkbook
'Every other worksheet only copies over data
'Now that we initialize our two workbooks we will now copy it in the corresponding sheets
For Each ws In wbBook1.Worksheets
With ws
If ws.Index = 1 Then
.Range("A2:D" & Cells(Rows.Count, "C").End(xlUp).Row).Copy wbBook2.Sheets(1).Range("A1")
Else:
sheetIndex = sheetIndex + 1
wbBook2.Worksheets.Add After:=wbBook2.Sheets(sheetIndex - 1) 'Add additional worksheet on the end to paste our other data
.Range("A2:D" & Cells(Rows.Count, "C").End(xlUp).Row).Copy wbBook2.Sheets(sheetIndex).Range("A1")
End If
End With
Next ws
End Sub
You're almost there but you need to be specific about which sheets and workbooks you're dealing with. Also, you don't need to select them to copy / paste.
Assuming the sheet you're pasting to in Book2.xlsm is Sheet1:
Sub CopyData()
' Copy A:D from all sheets to template
Dim ws As Worksheet, ws2 as worksheet
Dim sheetIndex As Integer
Dim wb1 as workbook, wb2 as workbook
Set wb1 = Workbooks("Book1.xlsx")
set wb2 = Workbooks("Book2.xlsx")
Set ws = wb1.sheets(1)
set ws2 = wb2.sheets(2)
'First Sheet pulls in headers and data
ws.Range("A1:D" & Cells(Rows.Count, "C").End(xlUp).Row).Copy ws2.range("A1")
'Every other worksheet only copies over data
For Each ws In wb1
If ws.Index <> 1 Then
ws.Range("A2:D" & Cells(Rows.Count, "C").End(xlUp).Row).Copy ws2.Range("A1").End(xlDown).Offset(1,0)
End If
Next ws
End Sub
Related
I have data in Sheet1 in range A2:D17.
I want to copy this data & paste in various multiple sheets (count of sheets are 12).
Sub CopyData()
Dim ws As Worksheet
Dim wsStart As Worksheet
Set wsStart = Worksheets("Sheet1")
For Each ws In ThisWorkbook.Sheets
If Not ws.Name = wsStart.Name Then
wsStart.Range("A2:D17").Copy
ws.Range("A2").PasteSpecial (xlPasteAll)
End If
Next ws
End Sub
I would to copy paste the first cell of a sheet trough the last row for all sheets in a workbook and my code is not working, the code is done on the active sheet only.
Sub Macro5()
'
' Macro5
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
Range("A2").Copy Destination:=Range("A3:A" & Cells(Rows.Count, "B").End(xlUp).Row)
Next ws
End Sub
Thanks for your help
Looping the worksheets does not make them active. You want something like this.
Dim WS As Excel.Worksheet
Dim iIndex As Integer
For iIndex = 1 To ActiveWorkbook.Worksheets.count
Set WS = Worksheets(iIndex)
With WS
'Do something here.
.Range("A2").Copy Destination:=.Range("A3:A" & .Cells(.Rows.Count, "B").End(xlUp).Row)
End With
Next iIndex
You could use the ws in your loop, but I always set the object.
For Each ws In ActiveWorkbook.Worksheets
ws.Range("A2").Copy Destination:=ws.Range("A3:A" & Cells(Rows.Count, "B").End(xlUp).Row)
Next ws
I would to copy paste the first cell of a sheet trough the last row for all sheets in a workbook and my code is not working, the code is done on the active sheet only.
Sub Macro5()
'
' Macro5
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
Range("A2").Copy Destination:=Range("A3:A" & Cells(Rows.Count, "B").End(xlUp).Row)
Next ws
End Sub
Thanks for your help
Looping the worksheets does not make them active. You want something like this.
Dim WS As Excel.Worksheet
Dim iIndex As Integer
For iIndex = 1 To ActiveWorkbook.Worksheets.count
Set WS = Worksheets(iIndex)
With WS
'Do something here.
.Range("A2").Copy Destination:=.Range("A3:A" & .Cells(.Rows.Count, "B").End(xlUp).Row)
End With
Next iIndex
You could use the ws in your loop, but I always set the object.
For Each ws In ActiveWorkbook.Worksheets
ws.Range("A2").Copy Destination:=ws.Range("A3:A" & Cells(Rows.Count, "B").End(xlUp).Row)
Next ws
I want to select and copy the first 3 rows and the last row in an Excel worksheet but in my code below the line Selection.Copy gives an error.
Sub SaveLastLine()
Dim WB As Workbook, filename As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Range("B1").Select
Selection.End(xlDown).Select
Union(Range("1:3"), Range(Selection, Selection.End(xlToRight))).Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
End Sub
Please anyone can help me.
Working with selected ranges is probably your problem. Kellsens has given you a solution that works around this by first copying the first three rows, then copying the last row to the new worksheet.
If you want to do this all in one shot, you can first define the range, then copy the content of that range to the new workbook. Something like this:
Sub SaveLastLine()
Dim WB As Workbook
Dim myRange As Range
'copy the content
Set myRange = Union(Range(Range("B1:B3"), Range("B1:B3").End(xlToRight)), _
Range(Range("B1").End(xlDown), Range("B1").End(xlDown).End(xlToRight)))
myRange.Copy
'paste the content
Set WB = Workbooks.Add
WB.ActiveSheet.Range("A1").PasteSpecial
End Sub
When you create your new workbook, there's no activesheet to paste, that's the error cause. You could instantiate your new workbook to the declared variable Wb.
Considering that your data starts in "B1" and considering that your new worksheet will have 4 rows, I made some modifications to your code:
Sub SaveLastLine()
Dim wb As Workbook
Dim ws As Worksheet
Dim filename As String
Dim lastCol As Integer
Dim lastRow As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set ws = ActiveSheet ' Here I instantiate the active worksheet
Set wb = Workbooks.Add ' Here I instantiate the new workbook
lastCol = ws.Range("B1").End(xlToRight).Column
lastRow = ws.Range("B1").End(xlDown).Row
ws.Range(ws.Cells(1, 2), ws.Cells(3, lastCol)).Copy wb.Worksheets(1).Range("B1") ' Here I copy the first 3 rows and paste in the first worksheet of your new workbook
ws.Range(ws.Cells(lastRow, 2), ws.Cells(lastRow, lastCol)).Copy wb.Worksheets(1).Range("B4") ' Here I copy the last row and paste
filename = "yourfilename.xlsx"
wb.SaveAs filename
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
This question already has answers here:
Loop through Excel Sheets
(2 answers)
Closed 6 years ago.
I am using the below script to copy data from "Sheet1" of a multi-sheet Excel file into a master sheet of another Excel file. It's working perfectly for one sheet. Now I need to get it to run through all the sheets pasting the data into the next available row in the Master file.
Please note: all the sheets use the same password.
Please help!
Thanks,
Yohanan
Sub CopyRanges()
Dim WB1 As Workbook
Dim WB2 As Workbook
Dim LastRow As Long
Set WB1 = ActiveWorkbook
Set WB2 = Workbooks.Open(WB1.Path & "\Datafile.xls")
Sheets("Sheet1").Unprotect ("Password1")
With WB2.Sheets("Sheet1")
LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
End With
WB2.Sheets("71235").Range("B6:M" & LastRow).Copy
WB1.Sheets("Output").Range("A2").PasteSpecial xlPasteValues
Sheets("Sheet1").Protect ("FTCCTOR")
WB2.Close
End Sub
Try this:
Sub CopyRanges()
Dim WB1 As Workbook
Dim WB2 As Workbook
Dim LastRow As Long
Dim sht As Worksheet
Set WB1 = ActiveWorkbook
Set WB2 = Workbooks.Open(WB1.Path & "\Datafile.xls")
For Each sht In WB2.Sheets
With sht
.Unprotect ("Password1")
LastRow = .Range("B" & .Rows.count).End(xlUp).Row
WB1.Sheets("Output").Range("A" & WB1.Sheets("Output").Rows.count).End(xlUp).Resize(LastRow - 5, 12).value = .Range("B6:M" & LastRow).value
.Protect ("Password1")
End With
Next sht
WB2.Close
End Sub
When only wanting the values it is faster to assign the values than to copy them.