I have 100 worksheets in a workbook. In each sheet, there are blank rows for the first rows. For some sheets, the 8th row is where the data begins. For some sheets data begins on the 9th or 10th.
My code goes to the first row that has a value and then offset one row up. Then i need it to delete.
My code works on a single sheet just fine, but when i try to iterate through all the worksheets in the workbook, it doesn't go beyond the active worksheet.
What can i do to iterate through the worksheets?
Sub To_Delete_Rows_In_Range()
Dim iCntr
Dim rng As Range
Dim wb As Workbook
Set wb = ActiveWorkbook
For Each Ws In wb.Worksheets
Set rng = Range("A1", Range("A1").End(xlDown).Offset(-1, 0))
For iCntr = rng.Row + rng.Rows.Count - 1 To rng.Row Step -1
Rows(iCntr).EntireRow.Delete
Next
Next Ws
End Sub
Added Ws. in front of your range so it knows to change with the sheet.
Sub To_Delete_Rows_In_Range()
Dim iCntr
Dim rng As Range
Dim wb As Workbook
Set wb = ActiveWorkbook
For Each Ws In wb.Worksheets
Set rng = Ws.Range("A1", Ws.Range("A1").End(xlDown).Offset(-1, 0))
For iCntr = rng.Row + rng.Rows.Count - 1 To rng.Row Step -1
Ws.Rows(iCntr).EntireRow.Delete
Next
Next Ws
End Sub
Try a different approach, delete the first row over and over gain, until the content of A1 is not blank:
Do Until Ws.Range("A1").Value <> vbNullString
Ws.Rows(1).Delete
Loop
Related
Complete beginner for VBA so simpler the better.
I want to collect all sheet names in excel and insert them to the first row. I'm able to collect the names with macro that I found (bellow) but I don't know how to convert the values to be in the first row only and not in the first column?
Sub TestNames()
Dim Ws As Worksheet
Dim LR As Long
For Each Ws In ActiveWorkbook.Worksheets
LR = Worksheets("Worksheet Names").Cells(Rows.Count, 1).End(xlUp).Row + 1
'This LR varaible to find the last used row
Cells(LR, 1).Select
ActiveCell.Value = Ws.Name
Next Ws
End Sub
https://www.wallstreetmojo.com/vba-name-worksheet/#:~:text=In%20VBA%2C%20to%20name%20a,its%20name%20using%20Worksheet%20object.
Worksheet Names to First Row
Option Explicit
Sub TestNames()
Dim dws As Worksheet: Set dws = ThisWorkbook.Worksheets("Worksheet Names")
Dim sws As Worksheet
Dim c As Long
For Each sws In ThisWorkbook.Worksheets
c = c + 1
dws.Cells(1, c).Value = sws.Name
Next sws
End Sub
Very close, just check for last column, and re-arrange Cells(LR, 1).Select
like in example below.
Keep in mind, finding last row and last column is not very straight forward task, there are different methods, - investigate them and apply the one which fits the best.
Sub TestNames()
Dim Ws As Worksheet
Dim LastColumn As Long
For Each Ws In ActiveWorkbook.Worksheets
'LR = Worksheets("Worksheet Names").Cells(Rows.Count, 1).End(xlUp).Row + 1
LastColumn = Worksheets("Worksheet Names").Cells(1, Worksheets("Worksheet Names").Columns.Count).End(xlToLeft).Column + 1
Worksheets("Worksheet Names").Cells(1, LastColumn).Value = Ws.Name
Next Ws
End Sub
Update: I realized that I can't use union on multiple sheets.
What's the best choice that I have then?
I simply want to combine all sheets in the workbook into the first worksheet.
After I went through the existing questions, I've tried adding Set rng = nothing to clear my range, but it didn't help.
Sub Combine()
Dim J As Long
Dim Combine As Range
Dim rng As Range
'I want to start from the second sheet and go through all of them
For J = 2 To Sheets.Count
With Sheets(J)
Set rng = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
End With
For Each Cell In rng
If Combine Is Nothing Then
Set Combine = Cell.EntireRow
Else
Set Combine = Union(Combine, Cell.EntireRow)
End If
Next Cell
Set rng = Nothing
Next J
'Paste the whole union into the 1st sheet
Combine.Copy Destination:=Sheets(1).Range("A1")
End Sub
All this code gets me an error Method 'Union' of object '_Global failed
Update 2
Sub Combine2()
Dim rowcount As Long
For Each Sheet In Sheets
If Sheet.Index <> 1 Then
rowcount = Sheet.UsedRange.Rows.Count
Sheet.UsedRange.Copy Destination:=Sheets(1).Cells(Lastrow + 1, 1)
Lastrow = Lastrow + rowcount
End If
Next Sheet
End Sub
Really simple code, worked perfectly, thanks to #luuklag for leading me on this.
Indeed .Union method doesn't work across worksheets.
Instead, you could try looping through all your worksheets, copying the corresponding range and pasting it to the destination worksheet.
Something like the following would achieve this:
Sub test()
Dim destinationSheet As Worksheet
Dim sht As Worksheet
Dim destinationRng As Range
Dim rng As Range
Set destinationSheet = ThisWorkbook.Worksheets("Name of your worksheet")
For Each sht In ThisWorkbook.Worksheets
If sht.Name <> destinationSheet.Name Then
With sht
Set rng = .Range(.Range("A1"), .Range("A" & .Rows.Count).End(xlUp))
rng.Copy
End With
With destinationSheet
Set destinationRng = .Range("A" & .Rows.Count).End(xlUp)
If destinationRng.Address = .Range("A1").Address Then
destinationRng.PasteSpecial xlPasteValues
Else
destinationRng.Offset(1, 0).PasteSpecial xlPasteValues
End If
End With
End If
Next sht
End Sub
The code above pastes the ranges one by one, in the same column. It can be easily modified to paste the ranges in different columns, one next to the other.
This is my first time so sorry in advance.
I have a file with several sheets, I need to copy from A14 to I14 and then do
Range(Selection, Selection.End(xlDown)).Select
In order to capture all the data from the original range to the bottom, all sheets have different number of rows thats why I need to do that.
Once the data is selected I need to copy and paste in another tab called "Report", and I need to do that for each sheet in the workbook.
Everytime a sheet is paste into the "Report" tab next sheet needs to go in the next avialbale row of the "Report" tab in other words I can not paste above the last information. Is a rolling report.
Don't understand the issue, but some tips:
Find the last row used, using:
Dim LastRow As Long
Dim ws as Worksheet
LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
Note: column 1 (A) is searched.
Loop through all worksheets using:
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
'Your code goes here
next ws
Take this as base and adjust to your requirement. This program is Untested and may require adjustment for Header Rows. I have commented out Header Rows in program keeping in view you want to start from `Row1`
Sub CopyToReport()
Dim wrk As Workbook 'Workbook object - Always good to work with object variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'Master Worksheet
Dim rng As Range 'Range object
Dim colCount As Integer 'Column count in tables in the worksheets
'Speed things up
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Working in active workbook
Set wrk = ActiveWorkbook
'Create/Reset the Report sheet
If Evaluate("ISREF(Report!A1)") Then
wrk.Sheets("Report").Move After:=Worksheets(Worksheets.Count)
wrk.Sheets("Report").Cells.Clear
Else
wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count)).Name = "Report"
End If
Set trg = wrk.Sheets("Report")
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(1)
' colCount = sht.Cells(1, Columns.Count).End(xlToLeft).Column
colCount =9
'Now retrieve headers, no copy&paste needed
'With trg.Cells(1, 1).Resize(1, colCount)
' .Value = sht.Cells(1, 1).Resize(1, colCount).Value
' 'Set font as bold
' .Font.Bold = True
'End With
'We can start loop
For Each sht In wrk.Worksheets
'Execute on every sheet except the Master
If sht.Name <> "Master" Then
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
'Set rng = sht.Range(sht.Cells(1, 1), sht.Cells(Rows.Count, colCount).End(xlUp))
Set rng = sht.Range("A1:I14")
'Put data into the Master worksheet
trg.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
End If
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit
'Screen updating should be activated
Application.ScreenUpdating = True
End Sub
Is there a way to copy multiple selected cells from excel as shown below? It always copies the whole range from the first selected cell to the last cell, rather than copying the values from selected cells.
A VBA code will be useful.
The following will help, this will copy the specified ranges to the clipboard so you can paste them into Notepad:
Sub CopyToClipboard()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
'declare and set the worksheet you are working with, amend as required
ws.Range("B11:B12,B14,B18,B20,B22").Copy
'copy range to clipboard
End Sub
UPDATE:
A possible workaround for this would be to use a Temp worksheet and add the selected values into it and then copy that range into the Clipboard, a little long winded, but it would work:
Sub CopyToClipboard()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
'declare and set the worksheet you are working with, amend as required
Dim work As Worksheet
Dim arr() As Variant
i = 0
For Each work In ThisWorkbook.Worksheets
If work.Name = "Temp" Then
Application.DisplayAlerts = False
work.Delete
Application.DisplayAlerts = True
End If
Next
'if Temp worksheet exists then delete it
For Each c In Selection
i = i + 1
ReDim Preserve arr(1 To i)
arr(i) = c.Value
Next
'above add the values from selection to an array
Set ws2 = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws2.Name = "Temp"
'add a temporary worksheet
For x = LBound(arr) To UBound(arr)
ws2.Cells(x, 1).Value = arr(x)
Next x
'copy values from array into temp worksheet
LastRow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
ws2.Range("A1:A" & LastRow).Copy
'copy continuous range from Temp worksheet
End Sub
Would like to create a Macro to loop through all of the sheets in the workbook and select all the data from each worksheet and then paste said data into a single consolidate table on the "Master" sheet. All sheets have the same column heading to Column "AB".
Currently tried using this code but I have been unable to get anything to paste over onto the Master worksheet. Might be overthinking setting the range each tab.
Just looking for a simple solution to copy all active data from each sheet and paste it into one sheet so that is its all consolidated.
Thanks in advance!
Sub CombineData()
Dim wkstDst As Worksheet
Dim wkstSrc As Worksheet
Dim WB As Workbook
Dim rngDst As Range
Dim rngSrc As Range
Dim DstLastRow As Long
Dim SrcLastRow As Long
'Refrences
Set wkstDst = ActiveWorkbook.Worksheets("Master")
'Setting Destination Range
Set rngDst = wkstDst.Cells(DstLastRow + 1, 1)
'Loop through all sheets exclude Master
For Each wkstSrc In ThisWorkbook.Worksheets
If wkstSrc.Name <> "Master" Then
SrcLastRow = LastOccupiedRowNum(wkstSrc)
With wkstSrc
Set rngSrc = .Range(.Cells(2, 1), .Cells(SrcLastRow, 28))
rngSrc.Copy Destination:=rngDst
End With
DstLastRow = LastOccupiedRowNum(wkstDst)
Set rngDst = wkstDst.Cells(DstLastRow + 1, 1)
End If
Next wkstSrc
End Sub
Throwing another method into the mix. This does assume that the data you are copying has as many rows in column A as it does in any other column. It doesn't require your function.
Sub CombineData()
Dim wkstDst As Worksheet
Dim wkstSrc As Worksheet
Dim rngSrc As Range
Set wkstDst = ThisWorkbook.Worksheets("Master")
For Each wkstSrc In ThisWorkbook.Worksheets
If wkstSrc.Name <> "Master" Then
With wkstSrc
Set rngSrc = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 28)
rngSrc.Copy Destination:=wkstDst.Cells(Rows.Count, 1).End(xlUp)(2)
End With
End If
Next wkstSrc
End Sub
You have copied this from somewhere else and you have forgotten to copy the function that gets the last row of a worksheet, namely this one LastOccupiedRowNum
So add this function to the same module and the code should work. Please don't forget to mark this as the right answer if it did work:
Function LastOccupiedRowNum(Optional sh As Worksheet, Optional colNumber As Long = 1) As Long
'Finds the last row in a particular column which has a value in it
If sh Is Nothing Then
Set sh = ActiveSheet
End If
LastOccupiedRowNum= sh.Cells(sh.Rows.Count, colNumber).End(xlUp).row
End Function
Try finding the last row dynamically, rather than using .cells
Dim lrSrc as Long, lrDst as Long, i as Long
For i = 1 to Sheets.Count
If Not Sheets(i).Name = "Destination" Then
lrSrc = Sheets(i).Cells( Sheets(i).Rows.Count,"A").End(xlUp).Row
lrDst = Sheets("Destination").Cells( Sheets("Destination").Rows.Count, "A").End(xlUp).Row
With Sheets(i)
.Range(.Cells(2,"A"), .Cells(lrSrc,"AB")).Copy Sheets("Destination").Range(Sheets("Destination").Cells(lrDst+1,"A"),Sheets("Destination").Cells(lrDst+1+lrSrc,"AB"))
End With
End If
Next i
This should replace your sub and the related function.