VBA: Looping a condition through a range that compares values from other columns until the list ends - excel

Public Sub MainTOfomat()
Dim ShippingQty As Range
Dim ReceivedQty As Range
ActiveSheet.Columns("A:P").AutoFit
ActiveSheet.Range("A:P").AutoFilter Field:=13, Criteria1:="No"
ActiveSheet.Range("K:L").AutoFilter Field:=2, Criteria1:="<>"
Set ShippingQty = Range("K2")
Set ReceivedQty = ShippingQty.Offset(0, 1)
ShippingQty.Select
Do Until IsEmpty(ActiveCell)
If ShippingQty.Value = 0 Then
ShippingQty.Offset(0, 5) = "Needs Fulfillment"
ElseIf ShippingQty.Value > ReceivedQty.Value Then
ShippingQty.Offset(0, 5) = "Needs Receipt"
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub
The code is program is supposed to loop though each row in the column and fill in the statement based on the result of the condition for values in two other columns. The problem is that the loop goes through, but only the first line actually changes, and the auto filter code before the loop gets skipped.

Here is your macro fixed up.
As mentioned before your ShippingQty range and ReceivedQty do not change with the activecell. When moving to the next cell, that is the activecell. The filter range need to be the same. A:P is filtered, when changing to K:L ,field 2 actually becomes column B, so if you want to filter out non-blanks in column L you need the field 12.
Sub YourMacro()
Dim ShippingQty As Range
Dim ReceivedQty As Range
ActiveSheet.Columns("A:P").AutoFit
With ActiveSheet.Range("A:P")
.AutoFilter Field:=13, Criteria1:="No"
.AutoFilter Field:=12, Criteria1:="<>"
End With
Set ShippingQty = Range("K2")
Set ReceivedQty = ShippingQty.Offset(0, 1)
ShippingQty.Select
Do Until IsEmpty(ActiveCell)
If ActiveCell.Rows.Hidden = False Then
If ActiveCell.Value = 0 Then
ActiveCell.Offset(0, 5) = "Needs Fulfillment"
ElseIf ActiveCell.Value > ActiveCell.Offset(, 1).Value Then
ActiveCell.Offset(0, 5) = "Needs Receipt"
End If
End If
ActiveCell.Offset(1, 0).Select
Loop
ActiveSheet.AutoFilterMode = 0
End Sub
You can use this option as well without using selects.
Sub Option1()
Dim rng As Range, c As Range
Dim ws As Worksheet
Set ws = ActiveSheet
Application.ScreenUpdating = 0
With ws
Set rng = .Range("K2:K" & .Cells(.Rows.Count, "K").End(xlUp).Row)
With .Range("A:P")
.AutoFilter Field:=13, Criteria1:="No"
.AutoFilter Field:=12, Criteria1:="<>"
End With
For Each c In rng.SpecialCells(xlCellTypeVisible)
If c = 0 Then c.Offset(, 5) = "Needs Fulfillments"
If c > c.Offset(, 1) Then c.Offset(, 5) = "Needs Receipts"
Next c
.AutoFilterMode = False
End With
End Sub

Related

Select only first 5 values of a column after applying a filter to a particular column on a particular condition,without duplicates

i have applied autofilter to the column,that part pf the code is running properly ,but on that condition there are suppose 20 values in that column but i want only 5 ,any particular code would help
Dim rFirstFilteredRow As Range
With Worksheets("Sheet1")
With .Cells(1, 1).CurrentRegion
ActiveSheet.Range("$A$1:$D$6").AutoFilter Field:=4, Criteria1:="1"
With .Resize(.Rows.Count - 1, .Rows.Count).Offset(1, 0)
If CBool(Application.Subtotal(103, .Cells)) Then
Set rFirstFilteredRow = _
.SpecialCells(xlCellTypeVisible).Columns(2).Cells
rFirstFilteredRow.Copy
Range("G16").Select
ActiveSheet.Paste
End If
End With
End With
End With
End Sub
this helps in getting first column after filter but not the first five
Just add .Resize(5) when setting the width of rFirstFilteredRow to resize the selection to 5 rows high.
Example below (I shortened the code a lot):
Sub Answer()
Dim rFirstFilteredRow As Range
ActiveSheet.Range("$A$1:$D$6").AutoFilter Field:=4, Criteria1:="1"
With Worksheets("Sheet1").Cells(1, 1).CurrentRegion
With .Resize(.Rows.Count - 1, .Rows.Count).Offset(1, 0)
If CBool(Application.Subtotal(103, .Cells)) Then
' Select first 5 columns starting at column 2
Set rFirstFilteredRow = _
.SpecialCells(xlCellTypeVisible).Columns(2).Resize(5)
rFirstFilteredRow.Copy
Range("G16").Select
ActiveSheet.Paste
End If
End With
End With
End Sub
Sub macro2()
Const MAXROWS = 5
Dim ws As Worksheet, rng As Range
Dim i As Long, c As Range
Set ws = ThisWorkbook.Worksheets("Sheet1")
ws.Range("$A$1:$D$6").AutoFilter Field:=4, Criteria1:="1"
With ws.Cells(1, 1).CurrentRegion.Columns(2)
Set rng = .Cells.SpecialCells(xlCellTypeVisible)
End With
i = 0
For Each c In rng.Cells
If i > 0 Then ' skip header
ws.Range("G16").Offset(i - 1) = c.Value2
End If
i = i + 1
If i > MAXROWS Then Exit For
Next
End Sub

What's the way to set the code so that it looks for the last filled row in column A, and then eliminate the rows where column H has values =0?

Good morning,
currently I have this code to delete rows without due date (Column J) and amount paid=0 (Column H).
Sub delete_rows()
Range("A1").End(xlDown).Select
Sheets("AA").Select
Range("J2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-5]=0,"""",RC[-5])"
Range("J2").Select
Selection.AutoFill Destination:=Range("J2:J500"), Type:=xlFillDefault
Range("J2").End(xlDown).Select
Range("K2").Select
Application.ScreenUpdating = False
With Sheet2
For line = .Cells(.Rows.Count, "J").End(xlUp).Row To 2 Step -1
If .Cells(line, "J") = "" Then
.Rows(line).Delete
End If
Next linha
End With
Application.ScreenUpdating = True
ActiveCell.FormulaR1C1 = "=IF(RC[-4]="""","""",RC[-4])"
Range("K2").Select
Selection.AutoFill Destination:=Range("K2:K500"), Type:=xlFillDefault
Range("K2").End(xlDown).Select
Range("J1").Select
Application.ScreenUpdating = False
With Sheet2
For line = .Cells(.Rows.Count, "K").End(xlUp).Row To 2 Step -1
If .Cells(line, "K") = "" Then
.Rows(line).Delete
End If
Next line
End With
Application.ScreenUpdating = True
End sub()
I created a code with a defined number of lines...however it takes a long time for the code to run, because sometimes the number of lines is small and it always runs the 500 lines. What's the way to set the code so that it looks for the last filled row in column A, and then eliminate the rows where column H has values =0 and in column J no values?
Please check: find last cell. Also have a look at: avoid select.
Afterwards, I think you should be able to understand the following code, which should get you the required result:
Sub test()
Application.ScreenUpdating = False
'declare your variables
Dim ws As Worksheet
Dim Rng1 As Range, Rng2 As Range
Dim i As Long, lastRow As Long
Set ws = Sheets("AA")
With ws
'get last row in
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
'set ranges for loop
Set Rng1 = Range(.Cells(2, "H"), .Cells(lastRow, "H"))
Set Rng2 = Range(.Cells(2, "J"), .Cells(lastRow, "J"))
'reverse loop
For i = Rng1.Rows.Count To 1 Step -1
'check conditions for cell in "H" and "J"
If Rng1.Cells(i) = 0 And Rng2.Cells(i) = "" Then
'defined ranges start at row 2, hence +1
ws.Rows(i + 1).Delete
End If
Next i
End With
Application.ScreenUpdating = True
End Sub

in Excel VBA why does my code not work with SpecialCells type visible and work without it?

In columns Bk and CB they both contain formula's that will result in a code. Now CB will also contain four codes and a remove statement which if they match with the cell in column BK in the same row then take the value from CB and paste over hence overriding the value in BK with that code and then paste it red.
the above should be done only on a filtered range though.
The ignore #N/A are in there as the overide column will error out on almost everyline except for when there is a code to overide.
This macro works perfectly without the visible cells statement at the end of my with range line but as soon as the visible cells statement is added the loop only goes up to #N/A and disregards the rest of the ElseIF statement.
Here is my code below:
Option Explicit
Sub Override()
Dim x As Workbook: Set x = ThisWorkbook
Dim rRange As Variant, fltrdRng As Range, aCell As Range, rngToCopy As Range
Dim ws As Worksheet
Dim LR As Long
Dim LR2 As Long
Dim SrchRng As Range, cel As Range
Dim mRow
mRow = 2
Set ws = x.Worksheets("Data")
LR = ws.Range("CB" & ws.Rows.Count).End(xlUp).Row
LR2 = ws.Range("BK" & ws.Rows.Count).End(xlUp).Row
'clears any filters on the sheet
ws.AutoFilterMode = False
' turns formula's to manual
Application.Calculation = xlManual
'copies down the formula in Column BK ignoring the last two rows as they have already been pasted over.
ws.Range("BK2:BK4 ").AutoFill Destination:=ws.Range("BK2:BK" & LR2 - 2)
'filters on N/A's and 10 as these are the codes we are interested in overiding
ws.Range("$A$1:$CB$1").AutoFilter Field:=19, Criteria1:=Array( _
"10", "N/A"), Operator:= _
xlFilterValues
' will loop through all cells in specified range and ignore any error's and #N/A's and will paste over the code overided in CB column to the BK column if conditions are met.
On Error Resume Next
While IsEmpty(ws.Range("CB" & mRow)) = False
With ws.Range("CB" & mRow).SpecialCells(xlCellTypeVisible)
If .Value = "#N/A" Then
ElseIf .Value = "1234" Then
.Offset(0, -17).Value = "1234"
.Offset(0, -17).Interior.Color = vbRed
ElseIf .Value = "1235" Then
.Offset(0, -17).Value = "1235"
.Offset(0, -17).Interior.Color = vbRed
ElseIf .Value = "1236" Then
.Offset(0, -17).Value = "1236"
.Offset(0, -17).Interior.Color = vbRed
ElseIf .Value = "Remove" Then
.Offset(0, -17).Value = "Remove"
.Offset(0, -17).Interior.Color = vbRed
ElseIf .Value = "1237" Then
.Offset(0, -17).Value = "1237"
.Offset(0, -17).Interior.Color = vbRed
End If
End With
mRow = mRow + 1
Wend
'turn Formula 's back to automatic
Application.Calculation = xlAutomatic
End Sub
With ws.Range("CB" & mRow).SpecialCells(xlCellTypeVisible)
Using SpecialCells on just one cell is problematic.
Instead, use it on the entire filtered column, like this, which will replace your entire While...Wend loop (by the way, While...Wend is obsolete):
On Error Resume Next
Dim visibleCells As Range
Set visibleCells = ws.Range("CB2:CB" & LR).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If visibleCells Is Nothing Then Exit Sub
Dim cell As Range
For Each cell In visibleCells
If Not IsError(cell.Value) Then
Select Case cell.Value
Case "1234", "1235", "1236", "1237", "Remove"
cell.Offset(0, -17).Value = cell.Value
cell.Offset(0, -17).Interior.Color = vbRed
End Select
End If
Next

Deleting Multiple Rows based on a Set Criteria

Sub Macro()
Dim i As Long
For i = Cells(Rows.Count, 14).End(xlUp).Row To 2 Step -1
If Cells(i, 14).Value2 = "APPLE" Then
Rows(i).Delete
End If
Next i
Dim f As Long
For f = Cells(Rows.Count, 14).End(xlUp).Row To 2 Step -1
If Cells(f, 14).Value2 = "NAME" Then
Rows(f).Delete
End If
Next f
End Sub
I have the above mentioned code to delete all the rows that have apple and name on them, If possible I would like excel to execute the code in one or two lines. Your help would be greatly appreciated!
Dim i As Long
For i = Cells(Rows.Count, 14).End(xlUp).Row To 2 Step -1
IF Cells(i, 14).Value2 = "APPLE" OR Cells(i, 14).Value2 = "NAME" THEN Rows(i).Delete
Next i
The fast way to delete rows is using AutoFilter:
Sub FastDelete()
Dim rng As Range, rngVisible As Range
'//Remove filter if any
ActiveSheet.AutoFilterMode = False
'// Get range of only one column (N)
Set rng = Range(Cells(1, 14), Cells(Rows.Count, 14).End(xlUp))
'// Field:=1 because filter has only one field
rng.AutoFilter Field:=1, Criteria1:=Array("APPLE", "NAME"), Operator:=xlFilterValues
'// Have error handling in case if no data is found
On Error Resume Next
With rng
'// Use Offset and Resize to exclude header
Set rngVisible = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
End With
'// If rows were found (i.e. there's no error), delete them
If Err = 0 Then rngVisible.EntireRow.Delete
On Error GoTo 0
'// Remove filter
ActiveSheet.AutoFilterMode = False
End Sub

Auto filter to select just the visible rows

I have this code. It loops through a list for the filtering criteria, then if no data to select it shows all data again and loops to the next criteria. If it shows data it end(slDown) and selects all the data showing, copies it and pastes it into another worksheet.
The cleanup script cleans any blank rows and columns and then returns to the original data sheet and deletes the data selected for the copy paste.
The problem is when there is just one row. It moves to the row with data, but when I End(xlDown), it shoots all the way to the bottom and the paste then causes the macro to freeze up.
I nested another if statement to capture if there is only one line of data visible, but I cannot get it to function correctly. Any Suggestions on the nested if statement?
Dim criteria As String
Dim F As Range
Set Rng = Sheets("Reference").Range("W2:W36")
For Each F In Rng
criteria = F
ActiveSheet.Range("$AV$1").AutoFilter Field:=48, Criteria1:="=*BULK SUBSERVIENT*", Operator:=xlAnd
ActiveSheet.Range("$K$1").AutoFilter Field:=11, Criteria1:=criteria
Range("A2:CM" & ActiveSheet.UsedRange.Rows.Count + 1) _
.Cells.SpecialCells(xlCellTypeVisible).Rows(1).Select
If ActiveCell.Value = vbNullString Then
ActiveSheet.ShowAllData
Else
If (ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell)) = 2 Then
'Range(Selection).Select
Selection.Copy
Sheets("Bulk Subservient").Select
ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
Call cleanup
Else
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Bulk Subservient").Select
ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
Call cleanup
End If
End If
Next F
I figured it out.... Here is what I did. Thanks all!
I used this If ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Areas.Count <= 2
instead of this (ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell)) = 2
Dim criteria As String
Dim F As Range
Set Rng = Sheets("Reference").Range("W2:W36")
For Each F In Rng
criteria = F
ActiveSheet.Range("$AV$1").AutoFilter Field:=48, Criteria1:="=*BULK SUBSERVIENT*", Operator:=xlAnd
ActiveSheet.Range("$K$1").AutoFilter Field:=11, Criteria1:=criteria
Range("A2:CM" & ActiveSheet.UsedRange.Rows.Count + 1) _
.Cells.SpecialCells(xlCellTypeVisible).Rows(1).Select
If ActiveCell.Value = vbNullString Then
ActiveSheet.ShowAllData
Else
If ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Areas.Count <= 2 Then
'Range(Selection).Select
Selection.Copy
Sheets("Bulk Subservient").Select
ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
Call cleanup
Else
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Bulk Subservient").Select
ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
Call cleanup
End If
End If
Next F
I think your code could be much cleaner than this. I prefer to use an auxiliar funcion to make this filter. Something like this:
Function MyFilter(criteria as string) as Range
Set tableRange = ActiveSheet.UsedRange
' Filter
With tableRange
Call .AutoFilter(48, "*BULK SUBSERVIENT*")
Call .AutoFilter(11, criteria)
End With
On Error Resume Next
'This...
Set selectedRange = tableRange.SpecialCells(xlCellTypeVisible)
'...Or (how to remover title).
Set selectedRange = Intersect(tableRange.SpecialCells(xlCellTypeVisible), .[2:1000000])
On Error GoTo 0
With tableRange
Call .AutoFilter(11)
Call .AutoFilter(48)
End With
'Empty Criteria
If WorksheetFunction.CountA(selectedRange) < 2 Then
Exit Sub
End If
Set MyFilter = selectedRange
End Sub
Here is your original code rewritten using the Range.CurrentRegion property to define the range of cells to be filtered.
Dim criteria As String
Dim F As Range, rng As Range
With Worksheets("Reference")
Set rng = .Range(.Cells(2, 23), .Cells(Rows.Count, 23).End(xlUp))
End With
With ActiveSheet '<~~ set this to worksheets("Sheet1") as appropriate
If .AutoFilterMode Then .AutoFilterMode = False
With .Cells(1, 1).CurrentRegion
For Each F In rng
criteria = F
.AutoFilter Field:=48, Criteria1:="*BULK SUBSERVIENT*"
.AutoFilter Field:=11, Criteria1:=criteria
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
If CBool(Application.Subtotal(103, .Cells)) Then
.Copy Destination:=Sheets("Bulk Subservient").Cells(Rows.Count, 1).End(xlUp).Offset(1)
End If
End With
Next F
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
Here is the same thing that collects all of the criteria terms from the Reference worksheet into a variant array and uses that to filter for all terms at once.
Dim rng As Range
Dim vCRITERIA As Variant, v As Long
With Worksheets("Reference")
ReDim vCRITERIA(1 To 1) '<~~for alternate method
For Each rng In .Range(.Cells(2, 23), .Cells(Rows.Count, 23).End(xlUp))
vCRITERIA(UBound(vCRITERIA)) = rng.Value2
ReDim Preserve vCRITERIA(UBound(vCRITERIA) + 1)
Next rng
ReDim Preserve vCRITERIA(UBound(vCRITERIA) - 1)
End With
With ActiveSheet '<~~ set this to worksheets("Sheet1") as appropriate
If .AutoFilterMode Then .AutoFilterMode = False
With .Cells(1, 1).CurrentRegion
.AutoFilter Field:=48, Criteria1:="*BULK SUBSERVIENT*"
.AutoFilter Field:=11, Criteria1:=(vCRITERIA), Operator:=xlFilterValues
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
If CBool(Application.Subtotal(103, .Cells)) Then
.Copy Destination:=Sheets("Bulk Subservient").Cells(Rows.Count, 1).End(xlUp).Offset(1)
End If
End With
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
The latter is likely a few milli-seconds faster than the first.
The worksheet's SUBTOTAL function never includes filtered or hidden rows so asking for a count will determine if there is anything to copy. Resizing and offsetting moves to the filtered range.
You will need to reincorporate the Cleanup subroutine.

Resources