The code currently filters the data the way I need it to but when it copies it over it copies everything not just the filtered data. I know I can make it work using .select and then copying and pasting etc. but I would rather avoid that if possible. Any help would be appreciated.
Sub Auto_Filter()
Dim RNG As Range
Dim Open_Jobs_Report As Worksheet
Set Open_Jobs_Report = ThisWorkbook.Sheets("Open Jobs Report")
Dim Dashboard As Worksheet
Set Dashboard = ThisWorkbook.Sheets("Dashboard")
Dim PersonResponsible As Range
Dim Violations As Range
Dim CLM1 As Long
Dim CLM2 As Long
With Sheets("Open Jobs Report")
Set RNG = .Range("A1", .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft).Column))
RNG.AutoFilter Field:=19, Criteria1:="<>"
CLM1 = .Range("1:1").Find(What:="Person Responsible").Column
Set PersonResponsible = .Range(.Cells(1, CLM1), .Cells(1, CLM1).End(xlDown))
CLM2 = .Range("1:1").Find(What:="Violations").Column
Set Violations = .Range(.Cells(1, CLM2), .Cells(1, CLM2).End(xlDown))
End With
Dashboard.Range("B4:B1000").Value = PersonResponsible.Value
Dashboard.Range("E4:E1000").Value = Violations.Value
Dashboard.Range("B4:B1000").RemoveDuplicates , Header:=xlYes
Dashboard.Range("E4:E1000").RemoveDuplicates , Header:=xlYes
Open_Jobs_Report.ListObjects(1).AutoFilter.ShowAllData
End Sub
This will only copy the visible rows from your table on the Open_Jobs_Report sheet
Open_Jobs_Report.ListObjects(1).DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
Update after comments:
With Open_Jobs_Report.ListObjects(1)
Union(.ListColumns(9).DataBodyRange, .ListColumns(19).DataBodyRange).Copy
End With
Or using header names:
With Open_Jobs_Report.ListObjects(1)
Union(.ListColumns("Person Responsible").DataBodyRange, .ListColumns("Violations").DataBodyRange).Copy
End With
Thinking a bit more about it this is how I'd probably go about doing it:
Dim Open_Jobs_Report As Worksheet
Dim temp as Variant
Set Open_Jobs_Report = ThisWorkbook.Sheets("Open Jobs Report")
temp = Open_Jobs_Report.ListObjects(1).DataBodyRange.SpecialCells(xlCellTypeVisible).Value
With Dashboard
.Range(.Cells(4, 2), .Cells(3 + UBound(temp,1), 2)).Value = Application.Index(temp, , 9)
.Range(.cells(4, 5), .Cells(3 + UBound(temp, 1), 5)).Value = Application.Index(temp, , 19)
End With
This puts the entire visible part of the table into an array in memory and then sets the range equal to the bits you're interested in.
You are probably looking to use the the built-in AutoFilter.Range object of the worksheet.
ActiveSheet.AutoFilter.Range.Copy
Workbooks.Add.Worksheets(1).Paste
This link gives the full explanation
Related
I've encountered a problem run-time Error '424' object required.
This is the solution i've acquired from my previous post, after spending some time to troubleshoot, i still can't solve it. Thanks to #rawrplus for the solution and I am still learning Excel vba.
Link: Excel VBA Cutting rows from workbook1 and paste it in workbook2
Option Explicit
Private Sub table_to_table()
'Declaration
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set wb1 = Workbooks.Open("C:\Documents and Settings\lye.yan.nian\My Documents\testingmacro2.xlsx")
Set wb2 = Workbooks.Open("C:\Documents and Settings\lye.yan.nian\My Documents\testingmacro3.xlsx")
Set ws1 = wb1.Sheets("Test2")
Set ws2 = wb2.Sheets("Test1")
Dim res_lr As Long
Dim lr2 As Long
lr2 = ws2.Cells(Rows.Count, 2).End(xlUp).Row
MsgBox lr2 /* Testing is done as i can get this value */
Dim r As Range, ary
Set r = ws1.Application.Range(Cells(1, 2), Cells(1, 6)) /* Tested working as i can get this value too*/
ary = Application.Transpose(Application.Transpose(r.Value))
MsgBox Join(ary, " ")
Dim copyrange As Range
Dim i As Long /* This is declared */
For i = 2 To lr2
MsgBox i /* i did some testing on this and removed the below code */
Set copyrange = ws2.Application.Range(Cells(i, 2), Cells(i, 6)).Copy /* This is the part where i got the error i can't figure out why*/
res_lr = ws2.Cells(Rows.Count, 8).End(xlUp).Row
ws2.Range(Cells(res_lr, 8), Cells(res_lr, 12)).PasteSpecial xlPasteValues
Set copyrange = ws1.Application.Range(Cells(i, 2), Cells(i, 6)).Copy
ws2.Range(Cells(res_lr + 1, 8), Cells(res_lr + 1, 12)).PasteSpecial xlPasteValues
Next i
wb1.Close
End Sub
Set copyrange = ws2.Application.Range(Cells(i, 2), Cells(i, 6)).Copy
Range.Copy does not return a Range object reference that you can assign to a Range object variable. It's a member method that takes the contents of a range, and copies it into the clipboard.
Your copyrange isn't the result of the .Copy operation, it's the result of a ws2.Application.Range(...) call... which is malformed.
This might fix it1:
Set copyrange = ws2.Application.Range(Cells(i, 2), Cells(i, 6))
copyrange.Copy
....and this is what you probably meant to be doing:
Set copyrange = ws2.Range(ws2.Cells(i, 2), ws2.Cells(i, 6))
copyrange.Copy
1 it's bad code, because you have an explicit Worksheet reference (ws2), and from there you go to Application to grab whatever worksheet is currently active, and work off that - so you think you're working off ws2 when in reality you're working off whatever ActiveSheet currently happens to be. Same with the unqualified Cells calls, which implicitly refer to Application.ActiveSheet.Cells.
Try adding the word set on the line where it throws error.
Example: set x = 'something
I'm currently trying to copy and paste a dynamic range from one workbook to another in order to refresh an existing dashboard.
I've developed the code below, but continue to get error notifications on the italicized portion below:
Sub TransferData()
Dim x As Workbook
Dim y As Workbook
Set x = Workbooks.Open("C:\file1.xlsx")
Set y = Workbooks.Open("C:\file2.xlsx")
Set StartCell = Range("A1")
finalrow = x.Sheets("Worksheet Name").Cells(Rows.Count, 2).End(xlUp).Row
'Counts
FinalColumn = x.Sheets("Worksheet Name").Cells(1,
Columns.Count).End(xlToLeft).Column
*x.Sheets("Worksheet Name").Range(StartCell, Cells(FinalRow,
FinalColumn)).Copy*
y.Sheets("Worksheet Name").Range(Cells(1, 7), Cells(FinalRow,
FinalColumn)).Paste
End Sub
You have to declare the worksheet, which is the "parent" of Cells as well. Like this:
With x.Sheets("Worksheet Name")
.Range(StartCell, .Cells(finalrow, FinalColumn)).Copy
End With
With y.Sheets("Worksheet Name")
.Range(.Cells(1, 7)).PasteSpecial xlPasteAll
End With
This code copies data from one worksheet to another using column headers.
But I need a condition so that it copies only the rows where column L matches the value of $AB$1. I just can't seem to get the syntax right, it's just ignoring my added if statement and is just copying everything.
EDIT to clarify...I'm looking to copy only the rows where L# = $AB$1. Not copy all if L2 = AB1. Make sense?
Any ideas?
Sub Test()
Dim ws As Worksheet
Dim ws2 As Worksheet
Set ws = Worksheets("CurrentPayrollNonExempt")
Set ws2 = Worksheets("BiWkly Template")
With ws
For i = 1 To .UsedRange.Columns.Count
If (.Cells(2, "L").Value) = .Range("$AB$1").Value Then
Set x = ws2.Rows(4).Find(ws.Cells(1, i).Value, LookIn:=xlValues, Lookat:=xlWhole)
If Not x Is Nothing Then
y = .Cells(Rows.Count, i).End(3).Row
.Range(.Cells(2, i), .Cells(y, i)).Copy
ws2.Cells(5, x.Column).PasteSpecial xlValues
End If
Set x = Nothing
End If
Next i
End With
End Sub
Here's the minimal-edit version of what you want to do:
Sub Test()
Dim ws As Worksheet
Dim ws2 As Worksheet
Set ws = Worksheets("CurrentPayrollNonExempt")
Set ws2 = Worksheets("BiWkly Template")
With ws
' Filter out the rows to ignore
.UsedRange.Autofilter 12, .Range("$AB$1").Value ' column 12 = "L"
For i = 1 To .UsedRange.Columns.Count
Set x = ws2.Rows(4).Find(ws.Cells(1, i).Value, LookIn:=xlValues, Lookat:=xlWhole)
If Not x Is Nothing Then
y = .Cells(Rows.Count, i).End(3).Row
.Range(.Cells(2, i), .Cells(y, i)).Copy
ws2.Cells(5, x.Column).PasteSpecial xlValues
End If
Set x = Nothing
Next i
End With
End Sub
It just hides the rows where column L is not equal to the desired value. Pretty sure everything else should work as expected.
Be careful using UsedRange (in my edit and your original). Depending on your worksheet this can go very poorly, as UsedRange might not be what you're expecting. Better if you looped through the columns like: For i = 1 To .Cells(1, .Columns.Count).End(xlLeft).Column) and if you filtered on your known table range like .Range("A1:Z1000").Autofilter 'etc.
What is x and what is y? You never defined those. If you insert
Option Explicit
at the top of your module, it will force you to declare your variables.
I can't speak for everyone, but that seems like you're asking an awful lot out of a WITH statement. Personally, I would break that code up into more manageable and easier to read chunks, and your debugging will probably be easier to boot. There's no bonus points for condensing your code to the absolute minimum ;).
What is the data format of your spread sheets? Are you using tables? The table ListObject normally makes data handling a lot easier.
EDIT:
It appears you are only looping across all the columns in row 2, and you are never going down the rows. Add another control index, like this:
With ws
for j = 2 to .UsedRange.Rows.Count - 1
For i = 1 To .UsedRange.Columns.Count
If (.Cells(j, "L").Value) = .Range("$AB$1").Value Then
Set x = ws2.Rows(4).Find(ws.Cells(1, i).Value, LookIn:=xlValues, Lookat:=xlWhole)
If Not x Is Nothing Then
y = .Cells(Rows.Count, i).End(3).Row
.Range(.Cells(2, i), .Cells(y, i)).Copy
ws2.Cells(5, x.Column).PasteSpecial xlValues
End If
Set x = Nothing
End If
Next I
Next j
End With
The j loop should go down the rows, starting in row 2, and taking into account the end will be -1 due to the header row. The .Cells(j,"L") will thus be a constant value for each row pass.
I hope I understand what you want, since you are not advancing your search criteria, I took it outside the For loop.
Sub Test()
Dim ws As Worksheet
Dim ws2 As Worksheet
Set ws = Worksheets("CurrentPayrollNonExempt")
Set ws2 = Worksheets("BiWkly Template")
With ws
If Not IsError(Application.Match(.Range("$AB$1").Value, .Columns("L:L"), 0)) Then
For i = 1 To .UsedRange.Columns.Count
Set x = ws2.Rows(4).Find(ws.Cells(1, i).Value, LookIn:=xlValues, Lookat:=xlWhole)
If Not x Is Nothing Then
y = .Cells(Rows.Count, i).End(3).Row
.Range(.Cells(2, i), .Cells(y, i)).Copy
ws2.Cells(5, x.Column).PasteSpecial xlValues
End If
Set x = Nothing
Next i
Else
' for debug purposes only
MsgBox "Value in Cell $AB$1 not found"
End If
End With
End Sub
No matter what I do I can't get this error to go away. This current version of code is an effort to completely spell out each reference. I'm getting the error after the 'set range for BOM components' line. Most topics point out that using .Range(Cells()) without specifying where the cells are located will lead to this error, but I've done the complete overkill referencing so I'm not sure why it still errors out. Only one workbook here as well.
#Scott Craner #BruceWayne I figured it out finally; the Oracle report comes out in a pretty f****d up format, and the first sheet in the loop was causing the ranges to actually be unequal. As soon as I deleted that sheet it ran perfectly.
Sub Macro3()
'
' Macro3 Macro
'
' Keyboard Shortcut: Ctrl+c
'
Dim ws As Worksheet
Dim lastRow As Integer
Dim summaryRow As Integer
Dim currentSheetRows As Integer
Dim i As Integer
Dim j As Integer
summaryRow = 2
For Each ws In ActiveWorkbook.Worksheets
If ws.Range("L3") = "" Then
currentSheetRows = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row
i = summaryRow
j = summaryRow
'set range for item # and item UOM'
For j = summaryRow To (summaryRow + (currentSheetRows - 3))
Sheets("Summary").Cells(j, 1).Value = ws.Cells(2, 1).Value
Next j
For i = summaryRow To (summaryRow + (currentSheetRows - 3))
Sheets("Summary").Cells(i, 2).Value = ws.Cells(2, 1).Value
Next i
'set range for BOM components'
ThisWorkbook.Worksheets("Summary").Range(ThisWorkbook.Worksheets("Summary").Cells(summaryRow, 3), ThisWorkbook.Worksheets("Summary").Cells((summaryRow + (currentSheetRows - 3)), 6)).Value = ThisWorkbook.Worksheets(ws.Name).Range(ThisWorkbook.Worksheets(ws.Name).Cells(3, 6), ThisWorkbook.Worksheets(ws.Name).Cells(currentSheetRows, 9)).Value
summaryRow = summaryRow + currentSheetRows
End If
Next ws
End Sub
Woah - first, check that the ranges are equal sizes. Then, I highly suggest using some variables for your sheet names and ranges:
Sub t()
Dim summaryWS As Worksheet
Dim otherWS As Worksheet
Set summaryWS = ThisWorkbook.Sheets("Summary")
Set otherWS = ThisWorkbook.Worksheets(ws.Name)
Dim copyRng As Range, pasteRng As Range
With summaryWS
Set copyRng = .Range(.Cells(SummaryRow, 3), .Cells((SummaryRow + (currentSheetRows - 3)), 6))
End With
With otherWS
Set pasteRng = .Range(.Cells(3, 6), .Cells(currentSheetRows, 9))
End With
pasteRng.Value = copyRng.Value
End Sub
Does that help your issue?
You're using
ActiveWorkbook
To set the loop current sheet
and then
ThisWorkbook
in the copy/paste values statement that errors
It may then be the workbook you're running the macro from (ThisWorkbook) differs from the currently active one (ActiveWorkbook) whose worksheets you're looping through
In such a case just change ThisWorkbook to ActiveWorkbook
The problem is here:
ThisWorkbook.Worksheets("Summary").Range(ThisWorkbook.Worksheets("Summary").Cells(summaryRow, 3), ThisWorkbook.Worksheets("Summary").Cells((summaryRow + (currentSheetRows - 3)), 6)).Value = ThisWorkbook.Worksheets(ws.Name).Range(ThisWorkbook.Worksheets(ws.Name).Cells(3, 6), ThisWorkbook.Worksheets(ws.Name).Cells(currentSheetRows, 9)).Value
the subscript is out of range.
Try
With Sheets(ws.name)
.Cells({var},{var}).Value = {var}
I am writing a VBA script that will delete (clear content) of the entire row if one of the cells within the rows is found to be blank or does not have any text or integer value.
I'm almost there, but I think my code is stuck in the for loop. Please let me know how I can further improve my code.
Sub Remove_Rows_BlankData()
For SheetCount = 1 To Sheets.Count 'SHEET LEVEL
Sheets(SheetCount).Visible = True
Sheets(SheetCount).Select
StartRow = 2
' EndRow = Cells(ActiveSheet.UsedRange.Rows.Count, 34)
LastRow = ActiveSheet.UsedRange.Rows.Count
LastCol = ActiveSheet.UsedRange.Columns.Count
Dim myRange As Range
Set myRange = Range(Cells(StartRow, 1), Cells(LastRow, LastCol))
'REMOVE ROWS W/ ANY BLANK CELLS
Dim DRow As Variant ' Sets DRow = Row w/ Blank
'From start row to last row
Cells.SpecialCells(xlCellTypeBlanks).EntireRow.Select
Selection.ClearContents
Next
End Sub
I've rewritten your sub to avoid having to Select a worksheet in order to use it. By referencing each worksheet in the loop using a With ... End With statement, the cells and properties of each worksheet can be dealt with without resorting to selecting¹ the worksheet just to use the inherent association of the ActiveSheet.
Sub Remove_Rows_BlankData()
Dim ws As Long, fr As Long, lr As Long, lc As Long
On Error Resume Next 'just in case there are no blank cells
For ws = 5 To Worksheets.Count 'SHEET LEVEL
With Worksheets(ws)
.Visible = True
'Sheets(SheetCount).Select 'not necessary to select in order to process
fr = 2
' EndRow = Cells(ActiveSheet.UsedRange.Rows.Count, 34)
lr = .UsedRange.Rows.Count
lc = .UsedRange.Columns.Count
With .Range(.Cells(fr, 1), .Cells(lr, lc))
.SpecialCells(xlCellTypeBlanks).EntireRow.ClearContents
End With
End With
Next ws
End Sub
Note that no variables are created (aka Dim) within the loop; only reassigned values.
¹ See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on select and activate to accomplish your goals.