I'm attempting to set the values shown in a combo box to the data shown in a single column of a filtered list so that it can be changed as required. Im running into error 1004 Application-defined object error when using a variable to define the range for the list items however.
the code i've written is:
Sub Vehicle_Catergory()
Dim LastRow As String
LastRow = Sheets("Vehicle_Data").Range("B2").End(xlDown).Address
Sheets("marine Vehicle Selection").ListBox_Vehicle_selection.Clear
'MsgBox LastRow.Address
'Filters vehicle Data for vehicle Types
Dim Criteria_1 As Range
'selects the criteria
Set Criteria_1 = Sheets("Config").Range("A3")
'copies the filtered data to the destination
With Sheets("Vehicle_data").Range("A2")
.AutoFilter field:=1, Criteria1:=Criteria_1
End With
Sheets("marine Vehicle Selection").ListBox_Vehicle_selection.List = Sheets("Vehicle_Data").Range("B3:LastRow").SpecialCells(xlCellTypeVisible).Value
End Sub
the error occurs in the last line, at the LastRow variable, it works when replaced with a cell address but i need it to be able to vary with a changing list length.
I have also tried setting lastRow to a range and using LastRow.adress to no avail and the same error
Could you test this?
Sub Vehicle_Catergory()
Dim LastRow As Range
LastRow = Sheets("Vehicle_Data").Range("B2").End(xlDown).Address
Sheets("marine Vehicle Selection").ListBox_Vehicle_selection.Clear
Sheets("Vehicle_Data").Range("B2").Select
Selection.End(xlDown).Select
Set LastRow = Selection
'Filters vehicle Data for vehicle Types
Dim Criteria_1 As Range
'selects the criteria
Set Criteria_1 = Sheets("Config").Range("A3")
'copies the filtered data to the destination
With Sheets("Vehicle_data").Range("A2")
.AutoFilter field:=1, Criteria1:=Criteria_1
End With
Sheets("marine Vehicle Selection").ListBox_Vehicle_selection.List = Sheets("Vehicle_Data").Range("B3:" & LastRow.Address).SpecialCells(xlCellTypeVisible).Value
End Sub
A range needs Column and row for both start and end:
Sheets("marine Vehicle Selection").ListBox_Vehicle_selection.List = Sheets("Vehicle_Data").Range("B3:B" & LastRow).SpecialCells(xlCellTypeVisible).Value
Also, try this method of lastrow, this should work better with some cells being empty and thus giving you a false value of lastrow:
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("Vehicle_Data") 'or declare Dim wb As Workbook and set it to what you need with ws then as Set ws = wb.Sheets("Vehicle_Data")
'or just skip the ws and use the Range immediately if your code is only used here
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
Hope that helps :)
Related
When i am pasting Amount data which i copied from filtered range through VBA code, I do not get the correct result.
How can i copy and paste the correct filtered range in VBA?
I have tried in so many ways like visible cells and resize.
Dim Rangedata as Range, U as Range
'Table Range
Set Rangedata = D.Range("A1:C" & Range("A1").End(xlDown).Row)
Rangedata.AutoFilter Field:=2, Criteria1:=Log.Cells(8, 3)
'Amount which i want to copy without Header
Set U = D.Range("C1:C" & Range("C1").End(xlDown).Row)
U.Offset(1, 0).SpecialCells(xlCellTypeVisible).Select
U.copy
There are almost 22 Amounts but i am only getting 10 Amounts.
You'll need to add in variables to reference the two workbooks, but hopefully this example will work.
Sub CopyPasteFilteredRange()
Dim D As Worksheet
Dim Log As Worksheet
Dim PasteHere As Worksheet
Dim Rangedata As range, U As range
Dim Lastrow As Long 'Get Last Row
Set D = Worksheets("D")
Set Log = Worksheets("Log")
Set PasteHere = Worksheets("PasteHere") 'Added Sheet PasteHere as Example
'Remove Filtered Criteria Before Filtering
If ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
'Table Range
Set Rangedata = D.range("A1:C" & range("A1").End(xlDown).Row)
Rangedata.AutoFilter Field:=2, Criteria1:=Log.Cells(8, 3)
'Amount which i want to copy without Header
'If you have filtered above on Column B, but if there are blank cells in Col C .End(XlDown will stop at first blank value, so add lastRow to capture all used rows
Lastrow = D.UsedRange.Rows(D.UsedRange.Rows.Count).Row
Set U = D.range("C1:C" & Lastrow)
'Set U to Visable Cells otherwise what you are .copying is still = D.range("C1:C" & range("C1").End(xlDown).Row)
Set U = U.Offset(1, 0).SpecialCells(xlCellTypeVisible)
U.Copy 'Don't have to Select U
PasteHere.range("A1").PasteSpecial
End Sub
I am trying to loop through four tabs, copying data from three input tabs and pasting it into the remaining, master, tab. The code should loop through all the column headings on the master tab, find whether the same heading exists in any of input tabs and, if it does, copy and paste the data into the relevant column of the master tab.
At the moment, I have got all the data from the first input tab into the master tab but I am having difficulties getting data from the remaining input tabs to paste below the data from the first input tab.
This is the code as it stands at the moment:
Sub master_sheet_data()
Application.ScreenUpdating = False
'Variables
Dim ws1_xlRange As Range
Dim ws1_xlCell As Range
Dim ws1 As Worksheet
Dim ws2_xlRange As Range
Dim ws2_xlCell As Range
Dim ws2 As Worksheet
Dim ws3_xlRange As Range
Dim ws3_xlCell As Range
Dim ws3 As Worksheet
Dim ws4_xlRange As Range
Dim ws4_xlCell As Range
Dim ws4 As Worksheet
Dim valueToFind As String
Dim lastrow As String
Dim lastrow2 As String
Dim copy_range As String
'Assign variables to specific worksheets/ranges
'These will need to be updated if changes are made to the file.
Set ws1 = ActiveWorkbook.Worksheets("Refined event data - all")
Set ws1_xlRange = ws1.Range("A1:BJ1")
Set ws2 = Worksheets("Refined event data")
Set ws2_xlRange = ws2.Range("A1:BJ1")
Set ws3 = Worksheets("Refined MASH data")
Set ws3_xlRange = ws3.Range("A1:BJ1")
Set ws4 = Worksheets("Raw RHI data - direct referrals")
Set ws4_xlRange = ws4.Range("A1:BJ1")
'Loop through all the column headers in the all data tab
For Each ws1_xlCell In ws1_xlRange
valueToFind = ws1_xlCell.Value
'Loop for - Refined event data tab
'check whether column headers match. If so, paste column from event tab to relevant column in all data tab
For Each ws2_xlCell In ws2_xlRange
If ws2_xlCell.Value = valueToFind Then
ws2_xlCell.EntireColumn.Copy
ws1_xlCell.PasteSpecial xlPasteValuesAndNumberFormats
End If
Next ws2_xlCell
'Loop for - Refined ID data tab
'check whether column headers match. If so, paste column from MASH tab to the end of relevant column in all data tab
For Each ws3_xlCell In ws3_xlRange
If ws3_xlCell.Value = valueToFind Then
Range(ws3_xlCell.Address(), ws3_xlCell.End(xlDown).Address()).Copy
lastrow = ws1.Cells(Rows.Count, ws1_xlCell.Column).End(xlUp).Row + 1
Cells(ws1_xlCell.Column & lastrow).PasteSpecial xlPasteValuesAndNumberFormats
End If
Next ws3_xlCell
'Loop for - direct date data tab
'check whether column headers match. If so, paste column from direct J4U tab to the end of relevant column in all data tab
For Each ws4_xlCell In ws4_xlRange
If ws4_xlCell.Value = valueToFind Then
Range(ws4_xlCell.Address(), ws4_xlCell.End(xlDown).Address()).Copy
lastrow = ws1.Cells(Rows.Count, ws1_xlCell.Column).End(xlUp).Row + 1
Cells(ws1_xlCell.Column & lastrow).PasteSpecial xlPasteValuesAndNumberFormats
End If
Next ws4_xlCell
Next ws1_xlCell
End Sub
At the moment, this section of code:
For Each ws3_xlCell In ws3_xlRange
If ws3_xlCell.Value = valueToFind Then
Range(ws3_xlCell.Address(), ws3_xlCell.End(xlDown).Address()).Copy
lastrow = ws1.Cells(Rows.Count, ws1_xlCell.Column).End(xlUp).Row + 1
Cells(ws1_xlCell.Column & lastrow).PasteSpecial xlPasteValuesAndNumberFormats
End If
Next ws3_xlCell
Seems to be selecting the correct range on the correct sheet and copying it. The lastrow variable seems to be picking up the correct row on the master tab but the data is not pasted. I've tried naming the ranges and using Cells() rather than Range() but neither appeared to work.
Any ideas as to how to get the data to paste would be much appreciated.
Cheers,
Ant
What I did was make a function that would find the column header and return the data range from from that column.
Sub master_sheet_data()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim cell As Range, source As Range, target As Range
With ThisWorkbook.Worksheets("Raw RHI data - direct referrals")
For Each ws In Worksheets(Array("Refined event data - all", "Refined event data", "Refined MASH data"))
For Each cell In .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft))
Set source = getColumnDataBodyRange(ws, cell.Value)
If Not source Is Nothing Then
Set target = cell.Offset(.Rows.Count - 1).End(xlUp).Offset(1)
source.Copy
target.PasteSpecial xlPasteValuesAndNumberFormats
End If
Next
Next
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Function getColumnDataBodyRange(ws As Worksheet, ColumnHeader As Variant) As Range
Dim cell As Range
With ws
Set cell = .Rows(1).Find(What:=ColumnHeader, After:=.Range("A1"))
If Not cell Is Nothing Then
Set getColumnDataBodyRange = .Range(cell.Offset(1), cell.Offset(.Rows.Count - 1).End(xlUp))
End If
End With
End Function
I want to select the entire column that contain the names to copy it knowing that the Name column number can change between a spreadsheet and another and there is some blank cells in the middle (missing value)
Suppose that the Names column is the column B, so if I want to select the entire column even with the some blank cells in the middle I can use the following code:
Range("B2", Range("B" & Rows.Count).End(xlup)).Select
But the Name column number is variable. so i tried to make it like this :
Sub ColSelection ()
Dim NameHeader As range
'To select the header of Name column
Set NameHeader = ActiveSheet.UsedRange.Find("Name")
ActiveSheet.Range(NameHeader.Offset(1,0), Range(NameHeader & Rows.Count).End(xlUp)).select
' run tim error 1004 " Methode 'Range' of object '_Global' Failed
End sub
I guess that I have to replace the second NameHeader with his column address. how to do that? Should I set a Var to store the address of the range NameHeader, and use it. If it's the case how should I set this var, I mean as long or as Variant..ect?
Thanks :)
Is this what you are trying? I have commented the code so you should not have a problem understanding it. But if you still do then post your query.
Is this what you are trying?
Sub ColSelection()
Dim NameHeader As Range
Dim ws As Worksheet
Dim ColName As String
Dim LRow As Long
Dim rng As Range
Set ws = Sheet1 '<~~ Change as applicable
With ws
Set NameHeader = .UsedRange.Find("Name")
'~~> Check if we found the text
If Not NameHeader Is Nothing Then
'~~> Get the Column Name
ColName = Split(Cells(, NameHeader.Column).Address, "$")(1)
'~~> Get the last row in that range
LRow = .Range(ColName & .Rows.Count).End(xlUp).Row
'~~> Construct your range
Set rng = .Range(ColName & NameHeader.Row & ":" & ColName & LRow)
With rng
MsgBox .Address
'~~> Do whatever you want with the range
End With
End If
End With
End Sub
Screenshot
Unable to upload an image, Imgur is rejecting images for the time being. Will update it directly later.
http://prntscr.com/kftsad
No need to look at NameHeader.Address - just use its .Column - something like this (noting that you don't have to Select a Range before copying.
Sub GrabNameCol()
Dim NameHeader As Range
Set NameHeader = ActiveSheet.UsedRange.Find("Name")
If Not NameHeader Is Nothing Then
ActiveSheet.Range(NameHeader.Offset(1), Cells(Rows.Count, NameHeader.Column).End(xlUp)).Select ' or just .Copy
End If
End Sub
Sub test1a()
Dim NameHeader As Range
Set NameHeader = ActiveSheet.UsedRange.Find(InputBox("HEADER"))
If Not NameHeader Is Nothing Then
ActiveSheet.Range(NameHeader.Offset(1), Cells(Rows.Count, NameHeader.Column).End(xlUp)).Select
End If
End Sub
So I've got this sub I've pieced together that runs through all tabs in my workbook looking for a specific name, then copies all that data into a single sheet, at the next empty row.
Basically combining a bunch of similar sheets with same column format.
So my question is how do I modify this to loop through multiple groups of sheets? Right now, this is coded to only work for sheets named like "Group1" and copy into a single sheet called "raw_Group1".
How do I modify to then also look for "Group2", ... "GroupN"? The grouping name is not actually numbered, but something like "people" "stuff" "orders" etc. Each group has a different column structure and multiple sheets that I'm trying to combine.
Sub copy_Group1()
Dim ws As Worksheet
Dim Destws As Worksheet
Dim Last As Long
Dim wsLast As Long
Dim CopyRng As Range
Dim StartRow As Long
'This keeps the screen from updating until the end, makes the macro run faster
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'defines an existing "Raw_Group1" worksheet instead of creating a new one
Set Destws = ActiveWorkbook.Sheets("Raw_Group1")
'clears sheet first, leaving headers
Destws.Rows("2:" & Rows.Count).ClearContents
'Fill in the start row.
StartRow = 2
'Loop through all worksheets and copy the data to the summary worksheet.
For Each ws In ActiveWorkbook.Worksheets
If LCase(ws.Name) Like "group1*" Then
'Find the last row with data on the summary and source worksheets.
Last = LastRow(Destws)
wsLast = LastRow(ws)
'If source worksheet is not empty and if the last row >= StartRow, copy the range.
If wsLast > 0 And wsLast >= StartRow Then
'Specify the range to place the data. Four options for specifying the range
''Set CopyRng = sh.Range("A1:G1") 'whole block of columns
''Set CopyRng = ws.Range("A1:B" & LastRow) 'specific columns, to the last row
''Set CopyRng = ws.Range("B1").CurrentRegion 'uses the current block of data
Set CopyRng = ws.Range(ws.Rows(StartRow), ws.Rows(wsLast)) 'Set the range starting at row2
'Test to see whether there are enough rows in the summary worksheet to copy all the data.
If Last + CopyRng.Rows.Count > Destws.Rows.Count Then
MsgBox "There are not enough rows in the " & _
"summary worksheet to place the data."
GoTo ExitTheSub
End If
CopyRng.Copy ' This statement copies values and formats.
'paste values only
With CopyRng
Destws.Cells(Last + 1, "A").Resize(.Rows.Count, _
.Columns.Count).Value = .Value
End With
End If
End If
Next
ExitTheSub:
Application.Goto Destws.Cells(1)
'filter: turns off then on (resets)
If Destws.AutoFilterMode Then Destws.AutoFilterMode = False
Destws.Range("A1").AutoFilter
'AutoFit the column width in the summary sheet.
Destws.Columns.AutoFit
'turns screen updating back on
Application.ScreenUpdating = True
End Sub
Consider generalizing your workbook processing for each group by setting up parameters into your macro with following changed lines. If certain groups need specific processing use conditional If or Select Case blocks for those particular parameter values:
Sub copy_Group(group_name As Variant, dest_sheet As Variant)
...
Set Destws = ActiveWorkbook.Sheets(dest_sheet)
...
If LCase(ws.Name) Like group_name & "*" Then
...
End Sub
And then in another macro iteratively pass all pairs of group names and destination sheets when calling your above macro. Add accordingly if you need other parameters like Start_Row and even use other data structures (i.e., collection, dictionary) instead of anonymous nested array.
Sub RunLoop()
Dim var As Variant
For Each var In Array(Array("group1", "Raw_Group1"), Array("people", "ppl_dest"), _
Array("stuff", "stuff_dest"), Array("orders", "order_dest"), _
Array("other", "other_dest"))
Call copy_Group(var(0), var(1))
Next var
End Sub
Of course there's no reason you cannot embed this loop in previous macro but this may help in code organization, even abstraction between the steps.
Hmm...#parfait...So I tried your advice here. It kinda works, but doesn't seem to be passing the 'group name' (the 1st 'type') to the first if-statement
Sub RunLoop()
Dim var As Variant
For Each var In Array( _
Array("stuff", "Raw_stuff"), _
Array("people", "Raw_people"), _
Array("orders", "Raw_orders"))
Call copy_Group(var(0), var(1)) 'calls sub listed below
Next var
End Sub
=====================
Sub copy_Group(group_name As Variant, dest_sheet As Variant)
Dim ws As Worksheet
Dim Destws As Worksheet
Dim Last As Long
Dim wsLast As Long
Dim CopyRng As Range
Dim StartRow As Long
'This keeps the screen from updating until the end, makes the macro run faster
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'defines an existing worksheet instead of creating a new one
Set Destws = ActiveWorkbook.Sheets(dest_sheet)
'clears sheet first, leaving headers
Destws.Rows("2:" & Rows.Count).ClearContents
'Fill in the start row.
StartRow = 2
'Loop through all worksheets and copy the data to the summary worksheet.
For Each ws In ActiveWorkbook.Worksheets
If LCase(ws.Name) Like group_name & "*" Then
'Find the last row with data on the summary and source worksheets.
Last = LastRow(Destws)
wsLast = LastRow(ws)
'If source worksheet is not empty and if the last row >= StartRow, copy the range.
If wsLast > 0 And wsLast >= StartRow Then
'Specify the range to place the data. Four options for specifying the range
''Set CopyRng = sh.Range("A1:G1") 'whole block of columns
''Set CopyRng = ws.Range("A1:B" & LastRow) 'specific columns, to the last row
''Set CopyRng = ws.Range("B1").CurrentRegion 'uses the current block of data
Set CopyRng = ws.Range(ws.Rows(StartRow), ws.Rows(wsLast)) 'Set the range starting at row2
'Test to see whether there are enough rows in the summary worksheet to copy all the data.
If Last + CopyRng.Rows.Count > Destws.Rows.Count Then
MsgBox "There are not enough rows in the " & _
"summary worksheet to place the data."
GoTo ExitTheSub
End If
CopyRng.Copy ' This statement copies values and formats.
'paste values only
With CopyRng
Destws.Cells(Last + 1, "A").Resize(.Rows.Count, _
.Columns.Count).Value = .Value
End With
End If
End If
Next
ExitTheSub:
Application.Goto Destws.Cells(1)
'filter: turns off then on (resets)
If Destws.AutoFilterMode Then Destws.AutoFilterMode = False
Destws.Range("A1").AutoFilter
'AutoFit the column width in the summary sheet.
Destws.Columns.AutoFit
'turns screen updating back on
Application.ScreenUpdating = True
End Sub
Question:
Why is the Range.Find method not working when referencing a different workbook?
Problem:
I'm attempting to copy data between workbooks, but the Range.Find method is stopping with a "Run-time Error 1004". I'm using Excel 2007 on a Windows 7 machine.
Details:
On two workbooks, only Sheet1 is referenced or used for each workbook. I have a procedure (ztest) with the following outline:
Format the sheet
Loop through all cells in column E of workbook #1
Using the Range.Find method, find the value in column E of the workbook #2
Once found, set workbook #1 offset column = workbook #2 offset column
I'd like to do this with .Find - not using HLOOKUP or the like.
I've simplified the code somewhat, to narrow down what exactly is going on. This doesn't show step 4 above, but the error occurs in step 3, in the statement containing the .Find method:
Public Sub ztest2()
'set workbook titles
Const w1 As String = "05AR 20130920.xlsx"
Const w2 As String = "05AR 20130923.xlsx"
Dim cl As Variant
With Workbooks(w2).Worksheets(1)
'format the sheet
.Range("A1", "D1").EntireColumn.Hidden = True
'loop through all cells column E of workbook #1
For Each cl In .Range("E2", Cells(Rows.Count, "E").End(xlUp))
'find value of current cell in column E, workbook #2
Workbooks(w1).Worksheets(1) _
.Range("E2", Cells(Rows.Count, "E").End(xlUp)) _
.Find(what:=cl.Value, LookIn:=xlValues).Select
Next
End With
End Sub
It's very important that you structure your code very well so that there is no difficulty in understanding it. If it is required, write extra lines of code so that even if you see the code after 6 months, you can identify what your code does. Also fully qualify your objects.
Try this (UNTESTED). I have commented the code. So if you do not understand something then post back
Const w1 As String = "05AR 20130920.xlsx"
Const w2 As String = "05AR 20130923.xlsx"
Sub ztest2()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim cl As Range, ws1Rng As Range, ws2Rng As Range, aCell as Range
Dim lRowW1 As Long, lRowW2 As Long
'~~> Define your workbook and worksheets here
Set wb1 = Workbooks(w1)
Set ws1 = wb1.Sheets(1)
Set wb2 = Workbooks(w2)
Set ws2 = wb2.Sheets(1)
'~~> Work with First workbook to get last row and define your range
With ws1
lRowW1 = .Range("E" & .Rows.Count).End(xlUp).Row
Set ws1Rng = .Range("E2:E" & lRowW1)
End With
'~~> Work with Second workbook to get last row and define your range
With ws2
.Range("A1", "D1").EntireColumn.Hidden = True
lRowW2 = .Range("E" & .Rows.Count).End(xlUp).Row
Set ws2Rng = .Range("E2:E" & lRowW2)
For Each cl In ws2Rng
'~~> Do the find
Set acell = ws1Rng.Find(what:=cl.Value, LookIn:=xlValues)
'~~> Check if found or not. This is required else you will
'~~> get an error if no match found
If Not acell Is Nothing Then
'
'~~> Do what ever you want here
'
End If
Next
End With
End Sub