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.
Related
I have an old workbook with Conditional Formatting that has got out of hand in terms of random conditional formatting having evolved. I would like to loop through the sheet and delete all the conditional formatting that only refers to one cell (but preserve other formatting in the same cell and of course preserve the cell value etc.)
I have written the code in a separate sheet so that (1) I can re-use it and (2) the workbook itself doesn't need macros
So far, I can identify the cells but can't delete the formatting. The code I have is:
Option Explicit
Sub Delete_Conditional()
Dim fc As FormatCondition
Dim lLastRow As Long, lLastCol As Long
Dim rAllCells As Range, rCell As Range
Dim ws As Worksheet
Dim wb As Workbook
Set wb = Workbooks("Book1.xlsx")
Set ws = wb.Worksheets("Sheet1")
'Find last cell and set a range to cover all cells
lLastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
lLastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
Set rAllCells = Range(Cells(1, 1), Cells(lLastRow, lLastCol))
'Loop through all cells
For Each rCell In rAllCells.Cells
'Loop through all FormatConditions in the cell
For Each fc In rCell.FormatConditions
'Determine if the FormatCondition only applies to one cell
If fc.AppliesTo.Cells.Count = 1 Then
Debug.Print fc.AppliesTo.Address
'I have tried fc.Delete
'I have tried fc.AppliesTo.Delete
End If
Next fc
Next rCell
End Sub
When I go back to the sheet, I can see the formatting still exists.
When deleting from a collection of items sometimes it works better if you work backwards:
Sub Delete_Conditional()
Dim fc As FormatCondition
Dim lLastRow As Long, lLastCol As Long
Dim rAllCells As Range, rCell As Range
Dim ws As Worksheet
Dim wb As Workbook, i As Long
Set wb = Workbooks("Book1.xlsx")
Set ws = wb.Worksheets("Sheet1")
'Find last cell and set a range to cover all cells
lLastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
lLastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
Set rAllCells = Range(Cells(1, 1), Cells(lLastRow, lLastCol))
'Loop through all cells
For Each rCell In rAllCells.Cells
'Loop through all FormatConditions in the cell
For i = rCell.FormatConditions.Count To 1 Step -1
With rCell.FormatConditions(i)
If .AppliesTo.Cells.Count = 1 Then
Debug.Print .AppliesTo.Address
.Delete
End If
End With
Next i
Next rCell
End Sub
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
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.
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
I have a problem with VBA code not pasting values
The code goes as following
Set rngSrc = .Range("D29")
rngSrc.Copy Destination:=rngDst
The problem is that I get only #REF errors since the VBA tries to paste whatever the cell has but I would like it to paste special values and I cant make it work with paste special function.
Does someone know how to make it work?
You're almost there, but instead of the Destination method, you should be using PasteSpecial instead, check this nifty code below:
Private Sub copypaste()
Dim rngSrc As Range
Dim rngDest As Range
Dim ws As Worksheet: Set ws = Sheets("Your sheet name")
Set rngSrc = ws.Range("D29")
Set rngDest = ws.Range("A33") ' for example
rngSrc.Copy
rngDest.PasteSpecial xlPasteValues
End Sub
I feel like the code is pretty self-explanatory. Though if you have any questions, let me know
Your CombineDataFromAllSheets code should be:
Public Sub CombineDataFromAllSheets()
Dim wksSrc As Worksheet, wksDst As Worksheet
Dim rngSrc As Range, rngDst As Range
Dim lngLastCol As Long, lngSrcLastRow As Long, lngDstLastRow As Long
Set wksDst = ThisWorkbook.Worksheets("Import")
For Each wksSrc In ThisWorkbook.Worksheets
'These need updating on each pass of the loop.
'Set them at the start, rather than before the loop
'and at the end of the loop.
lngDstLastRow = LastOccupiedRowNum(wksDst)
lngLastCol = LastOccupiedColNum(wksDst)
Set rngDst = wksDst.Cells(lngDstLastRow + 1, 1)
If wksSrc.Name <> "Import" Then
lngSrcLastRow = LastOccupiedRowNum(wksSrc)
With wksSrc
Set rngSrc = .Range("D29")
rngSrc.Copy
rngDst.PasteSpecial xlPasteValues
End With
End If
Next wksSrc
End Sub