I am getting a runtime error 1004 if I'm not on the same page that the script is meant to run on, and I'd like to know why...
here is the code.
Option Explicit
Sub PO_Tracking()
Dim wsPOD As Worksheet
Dim wsPOT As Worksheet
Dim wsPOA As Worksheet
Dim cel As Range
Dim lastrow As Long, i As Long, Er As Long
Set wsPOD = Sheets("PO Data")
Set wsPOT = Sheets("PO Tracking")
Set wsPOA = Sheets("PO Archive")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
With wsPOD
'first bring columns F:G up to match their line
For Each cel In Intersect(.UsedRange, .UsedRange.Offset(5), .Columns(6))
If cel = vbNullString And cel.Offset(, -2) <> vbNullString Then
.Range(cel.Offset(1), cel.Offset(1, 1)).Copy cel
cel.Offset(1).EntireRow.Delete
End If
Next
'now fil columns A:D to match PO Date and PO#
For Each cel In Intersect(.UsedRange, .UsedRange.Offset(5), .Columns(1))
If cel = vbNullString And cel.Offset(, 5) <> vbNullString Then
.Range(cel.Offset(-1), cel.Offset(-1, 3)).Copy cel
End If
Next
'Blow away rows that are useless
lastrow = wsPOD.Range("A6").End(xlDown).Row
wsPOD.Range("M5:P5").Copy wsPOD.Range("M6:P" & lastrow)
Calculate
With Intersect(wsPOD.UsedRange, ActiveSheet.Columns("N"))
.AutoFilter 1, "<>Different"
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
With Intersect(wsPOD.UsedRange, ActiveSheet.Columns("P"))
.AutoFilter 1, "<>Full"
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
wsPOD.UsedRange.Copy Sheets.Add.Range("A1")
'Final Adjustments before transfering over to new sheet.
With ActiveSheet
.AutoFilterMode = False
Intersect(.UsedRange, .Columns("A")).Cut .Range("Q1")
Intersect(.UsedRange, .Columns("D")).Cut .Range("R1")
Intersect(.UsedRange, .Columns("C")).Cut .Range("S1")
Intersect(.UsedRange, .Columns("B")).Cut .Range("T1")
Intersect(.UsedRange, .Columns("G")).Cut .Range("U1")
Intersect(.UsedRange, .Columns("F")).Cut .Range("V1")
Intersect(.UsedRange, .Range("Q:V")).Copy wsPOT.Cells(Rows.Count, "B").End(xlUp).Offset(1)
.Delete
End With
lastrow = wsPOD.Cells(Rows.Count, "B").End(xlUp).Row
wsPOT.Range("R1:X1").Copy
wsPOT.Range("B3:H" & lastrow).PasteSpecial xlPasteFormats
wsPOT.Range("N2:O2").Copy wsPOT.Range("N3:O" & lastrow)
wsPOT.Range("P1:Q1").Copy wsPOT.Range("I3:J" & lastrow)
wsPOT.Range("K3:K" & lastrow).Borders.Weight = xlThin
End With
Application.CutCopyMode = False
End Sub
The error is here:
**With Intersect(wsPOD.UsedRange, ActiveSheet.Columns("N"))**
.AutoFilter 1, "<>Different"
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
You can't have an intersection of ranges on two sheets, so if ActiveSheet is not wsPOD, then
With Intersect(wsPOD.UsedRange, ActiveSheet.Columns("N"))
has to fail by definition.
EDIT ... and see #SiddharthRout's comment for the fix.
For why the error, see the answer by Doug Glancy.
In addition, for how to avoid it, use something like
Dim rng1 As Range, rng2 As Range
Set rng1 = wsPOD.UsedRange
Set rng2 = ActiveSheet.Columns("N")
If (rng1.Parent.Name = rng2.Parent.Name) Then
Dim ints As Range
Set ints = Intersect(rng1, rng2)
If (Not (ints Is Nothing)) Then
With ints
' Do your job
End With
End If
End If
It is typically good practice to verify an Intersection before using it.
to avoid the error one has to check for equality of the worksheet (myRange.Parent) like this:
if rng1.Parent is rng2.Parent then if Not Intersect( rng1, rng2 ) Is Nothing then _
'... your conditional code here ...
hint: the important thing to notice here is that you can't connect the two conditions with ... And ... since VBA evaluates all conditions and does not stop after evaluating the first even if it is False :-/
or make sure the range's worksheets are the same (e.g. ws1), meaning to explicitely specify/create/intersect your Range objects similar to this):
if Not Intersect( ws1.Range("A1:A2"), ws1.Range("A2:B2") ) Is Nothing then _
'... your conditional code here ...
Related
i need your help on the VBA code :
i would like to make a filter on a database according cells in another sheets
my code is working but make a filter only in one cell. How to filter if the code found all cells from the Range
Please see my code :
Sub test()
Sheets("Dashboard").Select
Dim arr As Variant
'arr = Sheets("Dashboard").Range("B4:B11")
With Sheets("Database")
With .Range("A1:Z" & .Cells(.Rows.Count, "A").End(xlUp).Row)
.AutoFilter 'Turn off any previous filtering
.AutoFilter Field:=1, Criteria1:=Sheets("Dashboard").Range("B4:B11")
End With
End With
End Sub
Thanks for your help
Please, test the next way:
Sub filterByRange()
Dim arr, rng As Range
Set rng = Sheets("Dashboard").Range("B4:B11")
rng.TextToColumns Destination:=rng.cells(1), FieldInfo:=Array(1, 2)
arr = rng.Value
arr = Application.Transpose(Application.Index(arr, 0, 1)) '1D array
With Sheets("Database")
With .Range("A1:Z" & .cells(.Rows.count, "A").End(xlUp).row)
.AutoFilter
.AutoFilter field:=1, Criteria1:=arr, Operator:=xlFilterValues
End With
End With
End Sub
Less is more. I adapted the code provided by #FaneDuru utilising some shortcuts. Please note that when it comes to AutoFilter, there’s (usually) no need to specify the complete range you want to filter – it filters all rows meeting the criteria so last column is irrelevant. As long as the data is contiguous, there’s no need to specify the last row either.
Provided for interest only.
Sub testFilter()
Dim Arr
Arr = Sheets("Dashboard").Range("B4:B11").Value
Arr = Application.Transpose(Application.Index(Arr, 0, 1))
With Sheets("Database").Range("A1").CurrentRegion
.AutoFilter 1, Array(Arr), 7
End With
End Sub
Try this:
Sub SubRangeBasedAutofilter()
'Declarations.
Dim RngCell As Range
Dim RngCriteria As Range
Dim StrCriteria() As String
Dim DblCriteriaCount As Double
'Selecting Dashboard sheet.
Sheets("Dashboard").Select '<-IS THIS NECESSARY?
'Setting RngCriteria.
Set RngCriteria = Sheets("Dashboard").Range("B4:B11")
'Redeclaring StrCriteria() with proper size.
ReDim StrCriteria(Excel.WorksheetFunction.Max(Excel.WorksheetFunction.CountA(RngCriteria) - 1, 1))
'Covering each in RngCriteria.
For Each RngCell In RngCriteria
'Checking if RngCell is not empty.
If RngCell.Value <> "" Then
'Storing the criteria.
StrCriteria(DblCriteriaCount) = "=" & RngCell.Value
DblCriteriaCount = DblCriteriaCount + 1
End If
Next
'Focusing Database sheet.
With Sheets("Database")
'Turning off any eventual autofilter.
.AutoFilterMode = False
'Setting a new autofilter.
With .Range("A1:Z" & .Cells(.Rows.Count, "A").End(xlUp).Row)
.AutoFilter Field:=1, Criteria1:=StrCriteria, Operator:=xlFilterValues
End With
End With
End Sub
I have the following code which should simply select a range of rows and delete them. Unfortunately it deletes the headers as well, no matter how I change the range.
I tried to change the "rng" parameter without success.
Thank you for the feedback you can provide.
Sub delete_rows_range()
'Application.ScreenUpdating = False
Dim rng, Rng_del As Range
Dim leg As Range
Set leg = Worksheets("Sheet1").Range("aB1")
Set rng = Worksheets("Sheet1").Range("b1")
If Worksheets("Sheet1").AutoFilterMode = True Then
Worksheets("Sheet1").AutoFilter.ShowAllData
End If
rng.Select
rng.AutoFilter Field:=2, Criteria1:=leg
'rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.delete
rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Select
Worksheets("Sheet1").AutoFilterMode = False
End Sub
Your problem is that you are using a single cell as the range.
When you .Offset a single cell range, then use `xlCelTypeVisible.EntireRow.Delete
Excel selects every cell on the sheet and deletes them.
You really should clarify your range with a properly defined range object. e.g.
Dim ws As Worksheet, lRow As Long, rng As Range
Set ws = Worksheets("Sheet1")
lRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = ws.Range("A1:AB" & lRow)
But if you want to use B1 as your rng you can replace your line, rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Select with this line...
rng.Range(Cells(2, 2), Cells(rng.Rows.Count, 2)).SpecialCells(xlCellTypeVisible).EntireRow.Delete
You are trying to select from a single cell range.
You should do instead:
Sub delete_rows_range()
'Application.ScreenUpdating = False
Dim rng, Rng_del As Range
Dim leg As Range
Set leg = Worksheets("Sheet1").Range("AB1")
Set rng = Worksheets("Sheet1").Range("B1")
If Worksheets("Sheet1").AutoFilterMode = True Then
Worksheets("Sheet1").AutoFilter.ShowAllData
End If
rng.Select
rng.AutoFilter Field:=2, Criteria1:=leg
'rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.delete
Worksheets("Sheet1").UsedRange.SpecialCells(xlCellTypeVisible).Rows(2).Select
Worksheets("Sheet1").AutoFilterMode = False
End Sub
Trying to copy a filtered table and paste the results to the bottom of another table.
With RollupWeekSheet
sh1Col = .Range("Table1").Cells(1).Column
LastRollupWeekRow = .Cells(.Rows.Count, sh1Col).End(xlUp).Row
End With
Dim ComboWeekTable As ListObject
Set ComboWeekTable = ComboWeekSheet.ListObjects("Table1")
Dim RollupTimeStamp As Date
RollupTimeStamp = RollupWeekSheet.Range("B3").Value
With ComboWeekTable
.Range.AutoFilter Field:=16, Criteria1:=">" & RollupTimeStamp
.DataBodyRange.Copy
End With
With RollupWeekSheet
.Cells(LastRollupWeekRow + 1, sh1Col).PasteSpecial xlPasteValues
ComboWeekTable.Range.AutoFilter Field:=1
Application.CutCopyMode = False
Application.ScreenUpdating = True
End With`
With ComboWeekSheet
If .AutoFilterMode Then
.AutoFilterMode = False
End If
End With
It keeps highlighting the ".Autofilter" located under my "With ComboWeekTable" line and saying "Invalid use of property", but I don't know why. Please help.
It's a case of getting to the correct properties of the ListObject
Assuming you want just the filtered data rows (and not the header):
With ComboWeekTable
.Range.AutoFilter Field:=4, Criteria1:=">" & RollupTimeStamp
.DataBodyRange.Copy
End With
Unlike SpecialCells this still works if the filter returns no rows (no error, doesn't paste anything), so no need for error trapping
Demo
Sub Demo()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lo As ListObject
Set ws1 = ActiveSheet
Set ws2 = ws1.Parent.Worksheets(ws1.Index + 1)
Set lo = ws1.ListObjects(1)
If lo.AutoFilter Is Nothing Then lo.Range.AutoFilter
lo.ShowAutoFilterDropDown = True
With lo
.Range.AutoFilter Field:=1, Criteria1:="=2"
If Application.Aggregate(3, 5, lo.ListColumns(1).DataBodyRange) > 0 Then 'Count All, ignoring hidden rows
.DataBodyRange.Copy
ws2.Range("D5").PasteSpecial xlPasteValues
End If
lo.AutoFilter.ShowAllData ' clear filter
End With
End Sub
Before running Demo
After running Demo
EDITED to match your setup. This worked for me in testing:
Sub Tester()
Dim rngPaste As Range, ComboWeekTable As ListObject
Dim RollupTimeStamp As Date
'find the paste position
With RollupWeekSheet.ListObjects("Table2").DataBodyRange
Set rngPaste = .Rows(.Rows.Count).Cells(1).Offset(1, 0)
End With
Set ComboWeekTable = ComboWeekSheet.ListObjects("Table1")
RollupTimeStamp = RollupWeekSheet.Range("B3").Value
With ComboWeekTable.DataBodyRange
.AutoFilter Field:=16, Criteria1:=">" & RollupTimeStamp
On Error Resume Next '<< ignore run-time error if no rows visible
.SpecialCells(xlCellTypeVisible).Copy rngPaste
On Error GoTo 0 '<< stop ignoring errors
.AutoFilter
End With
ComboWeekTable.Range.AutoFilter Field:=1
End Sub
I have some data that has both words and values in cells and I am trying to delete the rows that don’t have values in the cells. My code works now if all of the numbers are negative but if there are positive numbers then my code won’t work. How do I fix this?
Sub tval
Dim s As Long
Dim LastRow As Long
S=2
LastRow= cells.find(“*”,[A1],,, xlByRows,xlPreviousRow).row
Do until s>LastRow
DoEvents
If InStr(1,Cells(s,4), “-“) > 0 Then
S=s+1
Else
Cells(s,4).EntireRow.Delete
LastRow=LastRow -1
End if
Loop
End sub
When deleting rows, you should always start from the end.
Sub tval
Dim s As Long
Dim LastRow As Long
LastRow= Cells(Rows.Count, 1).End(xlUp).Row
For s= LastRow to 2 Step -1
If Not IsNumeric(Cells(s,4)) then
Cells(s,4).EntireRow.Delete
End if
Next s
End sub
This should work for you:
Sub tgr()
Dim ws As Worksheet
Dim rTextConstants As Range
Dim rTextFormulas As Range
Dim rCombined As Range
Set ws = ActiveWorkbook.ActiveSheet
'Exclude row 1 so that only text values found in rows 2+ are found
With ws.Range("A2", ws.Cells(ws.Rows.Count, ws.Columns.Count))
On Error Resume Next 'prevent error if no cells found
Set rTextConstants = .SpecialCells(xlCellTypeConstants, xlTextValues)
Set rTextFormulas = .SpecialCells(xlCellTypeFormulas, xlTextValues)
On Error GoTo 0 'remove on error resume next condition
End With
If Not rTextConstants Is Nothing Then Set rCombined = rTextConstants
If Not rTextFormulas Is Nothing Then
If rCombined Is Nothing Then Set rCombined = rTextFormulas Else Set rCombined = Union(rCombined, rTextFormulas)
End If
If Not rCombined Is Nothing Then
rCombined.EntireRow.Delete
Else
MsgBox "No cells containing text found in sheet '" & ws.Name & "'", , "Error"
End If
End Sub
May I suggest a bit of a different approach:
Before:
Code:
Dim RNG1 As Range, RNG2 As Range
Option Explicit
Sub TestCase()
With ActiveWorkbook.Sheets(1)
Set RNG1 = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
If RNG1.SpecialCells(xlCellTypeConstants, 1).Count <> RNG1.Cells.Count Then
Set RNG2 = Application.Intersect(RNG1, RNG1.SpecialCells(xlCellTypeConstants, 2))
RNG2.EntireRow.Delete
End If
End With
End Sub
After:
You'll need to change this around to suit your range obviously. It should be a good starting point nonetheless.
You can also use AutoFilter to filter the numbers, and delete the visible cells to accomplish this task. The code accounts for a header row.
With ThisWorkbook.Sheets("Sheet1")
With .Range("A1").CurrentRegion
.AutoFilter
.AutoFilter Field:=4, Criteria1:="<>*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter
End With
End With
Right people, I’m back again for some more help. I have a workbook where I add new worksheets every month with information which is exactly the same as before in structure. In column A, I have invoice numbers then details from columns B:J. In columns K & L there are comments manually added for all outstanding issues. What I want to do is be able to lookup invoices against the last worksheet and then copy comments in columns K & L into the new worksheet.
I have tried to create a bit of code but nothing is coming off it. The ActiveSheet is the newly created without comments. So i want to lookup invoice numbers in columns A and copy columns K & L where a match is found from last worksheet to columns K&L of the activesheet. I hope I make sense and thank you for helping
Option Explicit
Sub FindCopy_all()
Dim calc As Long
Dim Cel As Range
Dim LastRow As Long
Dim rFound As Range
Dim LookRange As Range
Dim CelValue As Variant
' Speed
calc = Application.Calculation
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Get Last row of data ActiveSheet, Col A
LastRow = ActiveSheet.Cells(1048576, 1).End(xlUp).Row
' Set range to look in
Set LookRange = ActiveSheet.Range("A1:A" & LastRow)
' Loop on each value (cell)
For Each Cel In LookRange
' Get value to find
CelValue = Cel.Value
' Look on previous sheet
With Sheets(Sheets.Count - 3)
Set rFound = .Cells.Find(What:=CelValue, _
After:=.Cells(1, 1), LookIn:=xlValues, _
Lookat:=xlWhole, MatchCase:=False)
' Reset
On Error GoTo endo
' Not found, go next
If rFound Is Nothing Then
GoTo NextCel
Else
' Found. last sheet, Col K & L to Active Sheet found Row, Col K & L
.Cells(rFound.Row, 11, 12).Resize(, 2).Copy ActiveSheet.Cells(Cel.Row, 11, 12)
End If
End With
NextCel:
Next Cel
Set rFound = Nothing
'Reset
endo:
With Application
.Calculation = calc
.ScreenUpdating = True
End With
End Sub
You are in a with statement on the previous sheet and no activesheet statement exist. Use:
.Cells(rFound.Row, 11).Resize(,2).Copy activesheet.Cells(cel.Row, 11)
Also, you shouldn't need On Error Resume Next as the range returned will be nothing and also be sure you set rFound = nothing after you've completed each find.
NextCel:
set rFound = nothing
my code:
Option Explicit
Sub FindCopy_all()
Dim calc As Long
Dim Cel As Range
Dim LastRow As Long
Dim rFound As Range
Dim LookRange As Range
Dim CelValue As Variant
' Speed
calc = Application.Calculation
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Get Last row of data ActiveSheet, Col A
LastRow = ActiveSheet.Cells(1048576, 1).End(xlUp).Row
' Set range to look in
Set LookRange = ActiveSheet.Range("A1:A" & LastRow)
' Loop on each value (cell)
For Each Cel In LookRange
' Get value to find
CelValue = Cel.Value
' Look on previous sheet
With Sheets(Sheets.Count - 1)
Set rFound = .Range("A:A").Find(What:=CelValue, _
After:=.Cells(1, 1), LookIn:=xlValues, _
Lookat:=xlWhole, MatchCase:=False)
' Not found, go next
If rFound Is Nothing Then
GoTo NextCel
Else
' Found. last sheet, Col K & L to Active Sheet found Row, Col K & L
.Cells(rFound.Row, 11).Resize(, 2).Copy ActiveSheet.Cells(Cel.Row, 11)
End If
End With
NextCel:
Set rFound = Nothing
Next Cel
With Application
.Calculation = calc
.ScreenUpdating = True
End With
End Sub
My suggestion is that your VBA code puts VLOOKUP formulas in the new worksheet to retrieve the invoice information like this:
activesheet.Cells(cel.Row, 11).formula="=VLOOKUP(...)"
then in order to replace the formulas with text your code could use
activesheet.Cells(cel.Row, 11).Copy
followed by
activesheet.Cells(cel.Row, 11).PasteSpecial xlPasteValues to replace the formulas with just text values
try my code
' Speed
calc = Application.Calculation
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Get Last row of data ActiveSheet, Col A
LastRow = ActiveSheet.Cells(activesheet.rows.count, 1).End(xlUp).Row
' Set VLOOKUP formula, search on the other sheet for the value in column A, return the value matchiung from column 11, and use EXACT MATCH.
'
' =VLOOKUP(A:A,Sheet1!A:L,11,FALSE) ' example
'
range("K1:K" & lastRow).formula="=VLOOKUP(A:A," & sheets(Worksheets.count-1).name & "!A:L,11, FALSE)"
activesheet.calculate
range("K1:K" & lastRow).copy
range("K1:K" & lastRow).pastespecial xlpastevalues ' remove the formulas
that should get you started, try stepping through that and check the VLOOKUP is acting on the right columns and let us know how you get on
Philip