I am trying to copy columns f:g from each tab in a file (wb). Each tab has a different amount of rows so I also need to include a ctrl+shift+down when selecting the range. When pasting into my current file (ws) I also need to consider an offset because I am pasting 2 columns each time (next to each other).
I tried the following code but I keep getting a Run time error (object doesn't support this property), what am I missing?
For i = 1 To wb.Sheets.Count
wb.Range("f2:G2").End(xlDown).Select.Copy
start.Offset(i + 2, 2).PasteSpecial xlPasteValues
Next i
Copy Values From All Worksheets
Sub Test()
' Before your code...
Const sFirstRowAddress As String = "F2:G2"
' First part of your code...
Dim wb As Workbook ' Set wb = ?
Dim Start As Range ' Set Start = ?
' New code...
' Using the first source worksheet, calculate the total number of rows
' ('trCount') and the number of columns ('cCount').
Dim trCount As Long
Dim cCount As Long
With wb.Worksheets(1).Range(sFirstRowAddress)
trCount = .Worksheet.Rows.Count - .Row + 1
cCount = .Columns.Count
End With
' Reference the first destination row ('drrg').
Dim drrg As Range: Set drrg = Start.Cells(1).Resize(, cCount)
Dim sws As Worksheet
Dim srg As Range
Dim slCell As Range
Dim drg As Range
Dim rCount As Long
For Each sws In wb.Worksheets
' Turn off AutoFilter.
If sws.AutoFilterMode Then sws.AutoFilterMode = False
' Reference the first source row...
With sws.Range(sFirstRowAddress)
' Attempt to reference the last non-empty cell ('slCell').
Set slCell = .Resize(trCount) _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If Not slCell Is Nothing Then ' a non-empty cell was found
rCount = slCell.Row - .Row + 1
Set srg = .Resize(rCount)
Set drg = drrg.Resize(rCount)
drg.Value = srg.Value ' copy values
Set drrg = drrg.Offset(rCount) ' next first destination row
'Else ' all source cells are empty; do nothing
End If
End With
Next sws
' The remainder of your code...
End Sub
Related
I'm trying to copy a range to the first empty row on the next sheet.
But sometimes there is only 2 rows with values and other times there are 5,6 or 7 rows.
I have this for now:
Private Sub test()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Set copySheet = Worksheets("Blad1")
Set pasteSheet = Worksheets("Games")
copySheet.Range("AG4:AS13").Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
It works to get it on the next sheet, but it seems to always take the empty cells that were pasted earlier into account when pasting.
So the first time I click it, I get say 2 filled rows, and 6 empty rows pasted, the next time, it pastes the 2 full rows on the 9th row instead of on the 3rd row.
The empty rows on sheet 1 do hold formulas, but they are not present in the destination cells after pasting.
It does do it's jobs when I select those empty cells, press 'delete', and the next time I use the macro, it does paste it on the 3rd row.
Any ideas how to solve this?
Tried looking up a solution, but nothing that really worked. I might have been searching in the wrong direction, so that's why I came here.
Copy Values (Empty vs Blank)
You have copied blank cells which are not empty and End(xlUp) detects them.
Before using the following, which will not copy blank cells, select the range from the first row below the last row with data to the bottom of the worksheet and press Del to get rid of any blank cells.
Sub CopyValues()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Sheets("Blad1")
Dim srg As Range: Set srg = sws.Range("AG4:AS13")
Dim scCount As Long: scCount = srg.Columns.Count
Dim dws As Worksheet: Set dws = wb.Sheets("Games")
Dim dfCell As Range: Set dfCell = dws.Range("A2")
Dim dlCell As Range
With dfCell
With .Resize(dws.Rows.Count - .Row + 1, dws.Columns.Count - .Column + 1)
Set dlCell = .Find("*", , xlFormulas, , xlByRows, xlPrevious)
End With
If Not dlCell Is Nothing Then
Set dfCell = .Offset(dlCell.Row - .Row + 1)
End If
End With
Dim drrg As Range: Set drrg = dfCell.Resize(, scCount)
Dim srrg As Range
For Each srrg In srg.Rows
If Application.CountBlank(srrg) < scCount Then
drrg.Value = srrg.Value
Set drrg = drrg.Offset(1)
End If
Next srrg
MsgBox "Values copied.", vbInformation
End Sub
My need is to autofilter a column of an excel sheet with the values coming from a range in another sheet using VBA. This range is dynamic and could include a variable number of rows (each cell contains a different text) that the code should take and use to autofilter the column in the main excel sheet.
Here is the code
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets("RecordTabella")
Dim srg As Range
Dim srCount As Long
With sws.Range("C2")
Dim lCell As Range: Set lCell = .Resize(sws.Rows.count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Sub ' empty criteria column range
srCount = lCell.Row - .Row + 1
Set srg = .Resize(srCount)
End With
Dim Data As Variant
If srCount = 1 Then ' one cell (row)
ReDim Data(1 To 1, 1 To 1): Data(1, 1).value = srg.value
Else ' multiple cells (rows)
Data = srg.value
End If
Dim arr() As String: ReDim arr(1 To srCount) ' 1D one-based
Dim r As Long
For r = 1 To srCount
arr(r) = Data(r, 1)
Next r
Dim dws As Worksheet: Set dws = wb.Worksheets("Applicazioni")
If dws.FilterMode Then dws.ShowAllData
Dim drg As Range: Set drg = dws.Range("A8:C1000")
drg.AutoFilter 1, arr, xlFilterValues
It works great but there is an issue, in case the column C has only one value (one row on C2 since C1 is header) the code should thake the text in C2 and use it to filter, instead it gives me the error "Run time 424 Object required" on this specific part of the code
If srCount = 1 Then
ReDim Data(1 To 1, 1 To 1): Data(1, 1).value = srg.value ' in this part there is the error
Data = srg.value
End If
Any idea on how to fix it? if the range has multiple rows the code run perfectly
I am trying to repurpose combine_data_from_all_sheets.vb to pull data from several tabs.
Starting at O7:T7.
The data starts in the same range for each tab.
Some tabs may not have data and can be skipped.
These tabs have formulas with double quotes instead.
If there is data there won't be any blank spaces.
If row 11 has data then so does 7, 8, 9 and 10
The areas that I'm having trouble with I wrote notes within the code, which is all of the text in full caps.
Option Explicit
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
'Notes: "Src" is short for "Source", "Dst" is short for "Destination"
'Set references up-front
Set wksDst = ThisWorkbook.Worksheets("AOD")
lngDstLastRow = LastOccupiedRowNum(wksDst) '<- defined below
lngLastCol = LastOccupiedColNum(wksDst) '<- defined below
'Set the initial destination range
Set rngDst = wksDst.Cells(lngDstLastRow + 1, 1)
'Loop through all sheets
For Each wksSrc In ThisWorkbook.Worksheets
'Skip template sheet
'WOULD LIKE TO ADD AN OR STATEMENT HERE, SOMETHING LIKE NAME <> "TEMPLATE" OR "LIST" THEN
If wksSrc.Name <> "Template" Then
'WOULD LIKE THIS TO SEARCH FOR LAST ROW WITH DATA THAT ISN'T DOUBLE QUOTES/A FORMULA WITH NO VISIBLE VALUES
'Identify the last occupied row on this sheet
lngSrcLastRow = LastOccupiedRowNum(wksSrc)
'Store the source data then copy it to the destination range
'WOULD LIKE TO ONLY COPY DATA IF THERE ARE VALUES IN CELLS, BUT MACRO IS PICKING UP CELLS WITH DOUBLE QUOTES
'WOULD LIKE FOR THE MACRO TO ONLY COPY IF DATA EXISTS IN RANGE "O7:T7", IF DATA EXISTS HERE, CONTINUE TO COPY ALL DATA BELOW UNTIL CELLS ARE EMPTY (SKIP CELLS WITH "" AS VALUES)
'WOULD LIKE TO COPY AND PASTE SPECIAL INSTEAD OF FORMULAS
With wksSrc
Set rngSrc = .Range("O7:T7")
rngSrc.Copy Destination:=rngDst
End With
'Redefine the destination range now that new data has been added
lngDstLastRow = LastOccupiedRowNum(wksDst)
Set rngDst = wksDst.Cells(lngDstLastRow + 1, 1)
End If
Next wksSrc
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT : Sheet, the worksheet we'll search to find the last row
'OUTPUT : Long, the last occupied row
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
Dim lng As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
With Sheet
lng = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End With
Else
lng = 1
End If
LastOccupiedRowNum = lng
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT : Sheet, the worksheet we'll search to find the last column
'OUTPUT : Long, the last occupied column
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedColNum(Sheet As Worksheet) As Long
Dim lng As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
With Sheet
lng = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
End With
Else
lng = 1
End If
LastOccupiedColNum = lng
End Function
Copy Data From Multiple Worksheets
Option Explicit
Sub CombineDataWorksheets()
' Define constants.
' Source
Const sFirstRowAddress As String = "O7:T7"
' The following two constants are related!
Const sNameExceptionsList As String = "AOD,Template,List"
Const sNameExceptionsDelimiter As String = ","
' Destination
Const dName As String = "AOD"
Const dFirstColumn As String = "A"
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the destination worksheet ('dws').
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
' Write the number of worksheet rows to a variable ('wsrCount').
Dim wsrCount As Long: wsrCount = dws.Rows.Count
' Using the destination worksheet with the source first row address,
' write the following three source properties to variables.
Dim cCount As Long ' Source/Destination Columns Count
Dim sfRow As Long ' Source First Row
Dim scrgAddress As String ' Source Columns Range Address
With dws.Range(sFirstRowAddress)
cCount = .Columns.Count
sfRow = .Row
scrgAddress = .Resize(wsrCount - sfRow + 1).Address
End With
' Reference the destination first row range.
Dim dfrrg As Range ' Destination First Row Range
' Attempt to reference the last destination worksheet's row,
' the row of the bottom-most NON-EMPTY cell.
' Note that the Find method with its LookIn argument's parameter
' set to 'xlFormulas' will fail if the worksheet is filtered.
' It will NOT fail if rows or columns are just hidden.
Dim dlCell As Range
Set dlCell = dws.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If dlCell Is Nothing Then ' the destination worksheet is empty
Set dfrrg = dws.Cells(1, dFirstColumn).Resize(, cCount)
Else ' the destination worksheet is not empty
Set dfrrg = dws.Cells(dlCell.Row + 1, dFirstColumn).Resize(, cCount)
End If
' Write the names from the name exception list to a zero-based string array,
' the name exceptions array ('sNameExceptions').
Dim sNameExceptions() As String
sNameExceptions = Split(sNameExceptionsList, sNameExceptionsDelimiter)
' Declare additional variables to be used in the loop.
Dim sws As Worksheet ' Source Worksheet
Dim srg As Range ' Source Range
Dim slCell As Range ' Source Last Cell
Dim rCount As Long ' Source/Destination Rows Count
Dim drg As Range ' Destination Range
' Loop through the worksheets collection of the workbook...
For Each sws In wb.Worksheets
' Check if the source name was NOT found in the name exceptions array.
If IsError(Application.Match(sws.Name, sNameExceptions, 0)) Then
' Reference the source columns range, the range from the first
' source row range to the bottom-most worksheet row range.
With sws.Range(scrgAddress)
' Attempt to reference the source worksheet's last row,
' the row of the bottom-most NON-BLANK cell.
' Note that the Find method with its LookIn argument's
' parameter set to 'xlValues' will fail if the worksheet
' is filtered, and even if rows or columns are just hidden.
Set slCell = .Find("*", , xlValues, , xlByRows, xlPrevious)
' Check if a source non-blank cell was found.
If Not slCell Is Nothing Then ' non-blank cell found
' Calculate the number of source/destination rows.
rCount = slCell.Row - sfRow + 1
' Reference the source range.
Set srg = .Resize(rCount)
' Reference the destination range.
Set drg = dfrrg.Resize(rCount)
' Write the values from the source to the destination range.
drg.Value = srg.Value
' Reference the next destination first row range.
Set dfrrg = dfrrg.Offset(rCount)
'Else ' non-blank cell not found; do nothing
End If
End With
'Else ' worksheet name is in the name exceptions array; do nothing
End If
Next sws
' Inform.
MsgBox "Data combined.", vbInformation
End Sub
Okay,
Option Explicit
Sub Pull_All_To_AOD()
Dim wksSrc As Worksheet 'Source Sheet
Dim wksDst As Worksheet 'Destination Sheet
Dim rngSrc As Range 'Source Range
Dim rngDst As Range 'Destination Range
Dim RowCount As Long
Set wksDst = ThisWorkbook.Worksheets("AOD")
'Iterate Worksheets
For Each wksSrc In ThisWorkbook.Worksheets
'Skip Template, AOD, and empty sheets
If wksSrc.Name <> "Template" And _
wksSrc.Name <> "AOD" And _
Trim(Application.WorksheetFunction.Concat(wksSrc.Range("O7:T7"))) <> "" Then
'Find Data Size
RowCount = wksSrc.Range("O" & Rows.Count).End(xlUp).Row - 6
'Copy Data to AOD sheet, next empty row
wksDst.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(RowCount, 6).Value = _
wksSrc.Range("O7").Resize(RowCount, 6).Value
End If
Next wksSrc
End Sub
I think this is what you're looking for. Let me know if I'm missing anything.
I have a filter in an excel sheet that I wish to step through
I have recorded the filter part. But what I now wish to do is loop through the remaining rows and paste the row numbers into another sheet, eg "Sheet2"
I think a collection might be what I need but am not sure.
Can you please correct the code and put me on the right track
Thanks, Peter
Sub FilterBOQ()
'
Dim rng As Range
Sheets("BOQ").Select
ActiveSheet.Outline.ShowLevels RowLevels:=2
ActiveSheet.ShowAllData
ActiveSheet.Range("$A$3:$S$2219").AutoFilter Field:=2, Criteria1:="110"
ActiveSheet.Range("$A$3:$S$2219").AutoFilter Field:=11, Criteria1:="<>0"
End Sub
Copy the Row Numbers of Filtered Rows (AutoFilter)
Option Explicit
Sub FilterBOQ()
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source worksheet ('sws').
Dim sws As Worksheet: Set sws = wb.Worksheets("BOQ")
' ...
sws.Outline.ShowLevels RowLevels:=2 ' ?
' Turn off AutoFilter.
If sws.AutoFilterMode Then sws.AutoFilterMode = False
' Reference the source range ('srg') (has headers).
Dim srg As Range: Set srg = sws.Range("A3:S2219")
' Reference the source data range ('sdrg') (no headers).
Dim sdrg As Range: Set sdrg = srg.Resize(srg.Rows.Count - 1).Offset(1)
' Autofilter the source range.
srg.AutoFilter Field:=2, Criteria1:="110"
srg.AutoFilter Field:=11, Criteria1:="<>0"
' Attempt to reference the (probably non-contiguous) filtered column range
' ('fcrg'), the intersection of the filtered rows of the source data range
' and the first (can be any) column of the source data range.
Dim fcrg As Range
On Error Resume Next
Set fcrg = Intersect( _
sdrg.SpecialCells(xlCellTypeVisible), sdrg.Columns(1))
On Error GoTo 0
' Turn off the autofilter.
sws.AutoFilterMode = False
' Validate the filtered column range. Inform and exit if 'Nothing'.
If fcrg Is Nothing Then
MsgBox "Found no filtered rows.", vbExclamation
Exit Sub
End If
' Using the number of cells in the filtered column range,
' define a 2D one-based one-column array, the destination array ('dData').
Dim dData() As Variant: ReDim dData(1 To fcrg.Cells.Count, 1 To 1)
' Declare additional variables to be used in the loop.
Dim sCell As Range ' Current Cell of the Filtered Column Range
Dim dr As Long ' Current Destination Array Row
' Loop through the cells of the filtered column range.
For Each sCell In fcrg.Cells
dr = dr + 1 ' next destination array row
dData(dr, 1) = sCell.Row ' write the row number
Next sCell
' Reference the destination worksheet ('dws').
Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet2")
' Reference the destination first cell ('dfCell').
Dim dfCell As Range: Set dfCell = dws.Range("A2")
' Reference the destination (one-column) range ('drg').
Dim drg As Range: Set drg = dfCell.Resize(dr)
' Write the values from the destination array to the destination range.
drg.Value = dData
' Clear below.
drg.Resize(dws.Rows.Count - drg.Row - dr + 1).Offset(dr).Clear
' Inform to not wonder if the code has run or not.
MsgBox dr & " row numbers copied.", vbInformation
End Sub
I want to paste a column selection (a2:a200) to the next available column to the right.
I am having trouble doing this.
Here I am copying the data from Tables and pasting it in the last available column to the right.
Sub CopyMonthData() Worksheets("Tables").Range("d2:d200").Copy _
Worksheets("SalesInvoicesMonth").Range("a" & Columns.Count).End(xlToLeft).Offset(1, 0) End Sub
How can I make this work?
You could use UsedRange instead.
Sub CopyMonthData()
Dim iLastCol as Integer
With Worksheets("SalesInvoicesMonth")
iLastCol = .UsedRange.Column + .UsedRange.Columns.Count - 1
Worksheets("Tables").Range("d2:d200").Copy .Cells(1,iLastCol + 1)
End With
End Sub
Declaring iLastCol helps you understand how to calculate the value but the variable is not required. You could replace it in the copy function by its actual value --> - 1 and + 1 cancel each other, so you get .Cells(1,.usedRange.Column + .UsedRange.Columns.Count) as destination range.
Copy to the Next Available Column
A Quick Fix (End)
I'm assuming that you want to copy the column range D2:D200 in the source worksheet (Tables) to the second row of the column after (next to) the last non-empty column of the destination worksheet (SalesInvoicesMonth) and that both worksheets reside in the workbook containing this code (ThisWorkbook). Also, I'm assuming that all columns in the destination worksheet have headers in the first row, which will be the row used to calculate the column number.
Sub CopyMonthDataSimple()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets("Tables")
Dim dws As Worksheet: Set dws = wb.Worksheets("SalesInvoicesMonth")
sws.Range("D2:D200").Copy _
dws.Cells(1, dws.Columns.Count).End(xlToLeft).Offset(1, 1)
End Sub
The first 1 in .Offset(1, 1) means the second row, while the second 1 means the column next to the column of the last (not hidden) header cell.
A More Flexible Solution (Find)
The following will copy the column range from the given cell (sFirst) to the bottom-most non-empty cell of the column of the source worksheet to the destination worksheet starting with the cell in the given row (dfrow) of the column after the last non-empty column.
Adjust (play with) the values in the constants section.
Sub CopyMonthData()
' Constants & Workbook
' Source
Const sName As String = "Tables"
Const sFirst As String = "D2"
' Destination
Const dName As String = "SalesInvoicesMonth"
Const dfRow As Long = 2
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Attempt to create a reference to the Source Column Range ('srg').
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sfCell As Range: Set sfCell = sws.Range(sFirst)
Dim sfOffset As Long: sfOffset = sfCell.Row - 1
Dim slCell As Range
' The bottom-most non-empty cell in the Source Column.
Set slCell = sfCell.Resize(sws.Rows.Count - sfOffset) _
.Find("*", , xlFormulas, , , xlPrevious)
If slCell Is Nothing Then
MsgBox "The range from the 'First Source Cell' to the bottom-most " _
& "cell of the 'Source Column' is empty.", _
vbCritical, "CopyMonthData"
Exit Sub
End If
' The following...
Dim srCount As Long: srCount = slCell.Row - sfOffset
Dim srg As Range: Set srg = sfCell.Resize(srCount)
' ... is another way of doing...
'Dim srg As Range: Set srg = sws.Range(sfCell, slCell)
' Attempt to create a reference
' to the Destination First Cell Range ('dfCell').
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dlCell As Range
' The bottom-most non-empty cell in the last non-empty column.
Set dlCell = dws.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious)
Dim dCol As Long
If dlCell Is Nothing Then ' The Destination Worksheet is empty.
dCol = 1
Else
If dlCell.Column = dws.Columns.Count Then
MsgBox "The 'Destination Last Column' is not empty.", _
vbCritical, "CopyMonthData"
Exit Sub
Else
dCol = dlCell.Column + 1
End If
End If
Dim dfCell As Range: Set dfCell = dws.Cells(dfRow, dCol)
' Copy
' Copy values, formats and formulas.
srg.Copy dfCell
' Or copy values (only) by assignment (more efficient (faster)).
'dfCell.Resize(srCount).Value = srg.Value
dfCell.EntireColumn.AutoFit
End Sub