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
Related
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
I have multiple sheets in a particular workbook, and n each sheet there are Employee Numbers. The sheets have already been sorted in a way that Column A is always the Employee Number.
So what I need to do is loop through all the sheets and apply the RemoveDuplicates function to delete all duplicate Employee Numbers found in Column A.
Note - I am not trying to have the Employee Number appear on only one sheet; I am trying to have the Employee Number appear only once on each sheet.
I have it working for when I name a specific sheet, but cannot get it to work in a loop.
Test1:
Sub deleteDuplicate()
Dim ws As Worksheet
Dim wkbk1 As Workbook
Dim w As Long
Dim lRow As Long
Dim iCntr As Long
Set wkbk1 = Workbooks("3rd Party.xlsm")
wkbk1.Activate
For Each ws In ThisWorkbook.Worksheets
' Find last row in column A
lRow = ws.Range("A" & ws.Rows.count).End(xlUp).Row
For iCntr = lRow To 1 Step -1
ws.lRow.RemoveDuplicates Columns:=1, Header:=xlYes
Next iCntr
Next ws
End Sub
Test2:
Sub deleteDuplicate()
Dim ws As Worksheet
Dim wkbk1 As Workbook
Dim w As Long
Dim lRow As Long
Dim iCntr As Long
Set wkbk1 = Workbooks("3rd Party.xlsm")
wkbk1.Activate
With wkbk1
For w = 1 To .Worksheets.count
With Worksheets(w)
.UsedRange.RemoveDuplicates Columns:=1, Header:=xlYes
End With
Next w
End With
End Sub
The issue in both tests
Set wkbk1 = Workbooks("3rd Party.xlsm") - it implies the code is not in ThisWorkbook, yet
Test 1 uses ThisWorkbook - explicitly (For Each ws In ThisWorkbook.Worksheets)
Test 2 uses ThisWorkbook - implicitly (With Worksheets(w))
For this to work the file "3rd Party.xlsm" must be open at the same time
Try the versions bellow, and if the code is not running in ThisWorkbook, update wb accordingly
(ThisWorkbook is the file where the VBA code is executed from)
.
Version 1 - determine last row and last column
Option Explicit
Public Sub DeleteDuplicates1()
Dim wb As Workbook, ws As Worksheet, lr As Long, lc As Long, ur As Range
On Error Resume Next 'Expected error: wb not found
Set wb = ThisWorkbook 'Workbooks("3rd Party.xlsm")
If Not wb Is Nothing Then
Application.ScreenUpdating = False
For Each ws In wb.Worksheets
lr = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Set ur = ws.Range("A1", ws.Cells(lr, lc))
ur.RemoveDuplicates Columns:=Array(1), Header:=xlYes
Next
Application.ScreenUpdating = True
End If
End Sub
.
Version 2 - UsedRange
Public Sub DeleteDuplicates2()
Dim wb As Workbook, ws As Worksheet
On Error Resume Next 'Expected error: wb not found
Set wb = ThisWorkbook 'Workbooks("3rd Party.xlsm")
If Not wb Is Nothing Then
Application.ScreenUpdating = False
For Each ws In wb.Worksheets
ws.UsedRange.RemoveDuplicates Columns:=Array(1), Header:=xlYes
Next
Application.ScreenUpdating = True
End If
End Sub
If nothing happens when you run either of these versions, the file "3rd Party.xlsm" doesn't exist.
Either it's not open currently, or the name is different - maybe "3rd Party.xlsx" (with an x)
.
If you still have errors for Version 2, .UsedRange may not be what you expect
Try cleaning extra rows and columns with this Sub
Public Sub RemoveEmptyRowsAndColumns()
Dim wb As Workbook, ws As Worksheet, lr As Long, lc As Long, er As Range, ec As Range
On Error Resume Next 'Expected error: wb not found
Set wb = ThisWorkbook 'Workbooks("3rd Party.xlsm")
If Not wb Is Nothing Then
Application.ScreenUpdating = False
For Each ws In wb.Worksheets
lr = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
If lr > 1 And lc > 1 Then
Set er = ws.Range(ws.Cells(lr + 1, "A"), ws.Cells(ws.Rows.Count, "A"))
Set ec = ws.Range(ws.Cells(1, lc + 1), ws.Cells(1, ws.Columns.Count))
er.EntireRow.Delete 'Shift:=xlUp
ec.EntireColumn.Delete 'Shift:=xlToLeft
End If
Next
Application.ScreenUpdating = True
End If
End Sub
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
This code does what I want per entry in the txtKB textbox:
Dim ws1 As Worksheet
Dim lastrow As Long
Dim clipboardObj As New MSForms.DataObject
Dim wstest As Worksheet
Dim clipboardTxt As String
Set ws1 = Sheets("Sheet6")
Set wstest = Sheets("Sheet8")
lastrow = ws1.Range("A" & Rows.Count).End(xlUp).Row
ws1.Range("M1:A" & lastrow).AutoFilter field:=13, Criteria1:=txtKB
ws1.Range("B" & Rows.Count).End(xlUp).Offset(1).Select
txtmedian = WorksheetFunction.Aggregate(12, 5, Columns(2))
clipboardTxt = txtmedian.Text
clipboardObj.SetText clipboardTxt
clipboardObj.PutInClipboard
wstest.Range("A" & Rows.Count).End(xlUp).Offset(1) = txtmedian
but I want to improve it (so that I will not need to manually input the ID in textbox txtKB criteria anymore, and automate everything with just one click of a button) to take an entry in ws2 Column A (like an ID), look it up in ws1 then perform the median extraction, paste the median in wstest then move to the next ID in ws2 until it goes through all IDs in ws2.
Note: ws2 is not yet in the code.
I need to place a loop somewhere I just don't know where.
You could try something like:
Dim ws as worksheet
Dim wb as workbook
set wb = ThisWorkbook
For Each ws in wb.Worksheets
' Do what you want here
next ws
This will loop through all worksheets in the workbook
To work it into your code
Dim wb as workbook
Dim ws As Worksheet
Dim lastrow As Long
Dim clipboardObj As New MSForms.DataObject
Dim wstest As Worksheet
Dim clipboardTxt As String
set wb = ThisWorkbook
Set wstest = Sheets("Sheet8")
For Each ws in wb.Worksheets ' Loop through all sheets in workbook
if not ws.name = wstest.name then ' Avoid sheet you're copying too (ammend as needed)
With ws
lastrow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("M1:A" & lastrow).AutoFilter field:=13, Criteria1:=txtKB
.Range("B" & Rows.Count).End(xlUp).Offset(1).Select
End With
txtmedian = WorksheetFunction.Aggregate(12, 5, Columns(2))
clipboardTxt = txtmedian.Text
clipboardObj.SetText clipboardTxt
clipboardObj.PutInClipboard
wstest.Range("A" & Rows.Count).End(xlUp).Offset(1) = txtmedian 'You will need to change your code to paste into different locations I would have assumed, I'll leave that up to you though
End if
Next ws