VBA Set Multiple Filters - excel

I've used filters manually, but never with VBA.
I have the following:
K2 - Item 1
L2 - Item 2
M2 - Item 3
N2 - Item 4
O2 - Item 5
P2 - Item 6
Q2 - Item 7
R2 - Item 8
S2 - Item 9
T2 - Item 10
then underneath each user with their Item. Some may have multiple items (i.e. P, R, S & T).
I want to create a "Drop down" (Which I can do haha) where it'll have the 10 Items in it, and when you select an Item, it sets all the filters to blank, but the one Item it, that's been selected, is the only one showing.
Currently doing it manually, but doing it for 10 different items is becoming a head ache!
Just looking to see if someone can point me in the right direction before I spiral down the rabbit hole?
Cheers
Edit:
Have started to try this code, and it does work, but takes forever to process (Downside of having 20k+ lines of data to sift through!)
Sub FilterMasks(mask As String)
Dim LastRow, RunningNum
LastRow = Sheets("Output").Range("A" & Rows.Count).End(xlUp).Row + 1
For RunningNum = 3 To LastRow
Sheets("Output").Rows(RunningNum).EntireRow.Hidden = False
If mask = "Type" Then
If Application.WorksheetFunction.CountA(Range("K" & RunningNum & ":T" & RunningNum)) > 0 Then
Sheets("Output").Rows(RunningNum).EntireRow.Hidden = True
End If
End If
If mask Like "Item 1" Then
If Application.WorksheetFunction.CountA(Range("J" & RunningNum)) = 1 Or Application.WorksheetFunction.CountA(Range("L" & RunningNum & ":T" & RunningNum)) > 0 Then
Sheets("Output").Rows(RunningNum).EntireRow.Hidden = True
End If
End If
If mask Like "Item 2" Then
If Application.WorksheetFunction.CountA(Range("J" & RunningNum & ":K" & RunningNum)) > 0 Or Application.WorksheetFunction.CountA(Range("M" & RunningNum & ":T" & RunningNum)) > 0 Then
Sheets("Output").Rows(RunningNum).EntireRow.Hidden = True
End If
End If
If mask Like "Item 3" Then
If Application.WorksheetFunction.CountA(Range("J" & RunningNum & ":L" & RunningNum)) > 0 Or Application.WorksheetFunction.CountA(Range("N" & RunningNum & ":T" & RunningNum)) > 0 Then
Sheets("Output").Rows(RunningNum).EntireRow.Hidden = True
End If
End If
If mask Like "Item 4" Then
If Application.WorksheetFunction.CountA(Range("J" & RunningNum & ":M" & RunningNum)) > 0 Or Application.WorksheetFunction.CountA(Range("O" & RunningNum & ":T" & RunningNum)) > 0 Then
Sheets("Output").Rows(RunningNum).EntireRow.Hidden = True
End If
End If
If mask Like "Item 5" Then
If Application.WorksheetFunction.CountA(Range("J" & RunningNum & ":N" & RunningNum)) > 0 Or Application.WorksheetFunction.CountA(Range("P" & RunningNum & ":T" & RunningNum)) > 0 Then
Sheets("Output").Rows(RunningNum).EntireRow.Hidden = True
End If
End If
If mask Like "Item 6" Then
If Application.WorksheetFunction.CountA(Range("J" & RunningNum & ":O" & RunningNum)) > 0 Or Application.WorksheetFunction.CountA(Range("Q" & RunningNum & ":T" & RunningNum)) > 0 Then
Sheets("Output").Rows(RunningNum).EntireRow.Hidden = True
End If
End If
If mask Like "item 7" Then
If Application.WorksheetFunction.CountA(Range("J" & RunningNum & ":P" & RunningNum)) > 0 Or Application.WorksheetFunction.CountA(Range("R" & RunningNum & ":T" & RunningNum)) > 0 Then
Sheets("Output").Rows(RunningNum).EntireRow.Hidden = True
End If
End If
If mask Like "Item 8" Then
If Application.WorksheetFunction.CountA(Range("J" & RunningNum & ":Q" & RunningNum)) > 0 Or Application.WorksheetFunction.CountA(Range("S" & RunningNum & ":T" & RunningNum)) > 0 Then
Sheets("Output").Rows(RunningNum).EntireRow.Hidden = True
End If
End If
If mask Like "Item 9" Then
If Application.WorksheetFunction.CountA(Range("J" & RunningNum & ":R" & RunningNum)) > 0 Or Application.WorksheetFunction.CountA(Range("T" & RunningNum)) > 0 Then
Sheets("Output").Rows(RunningNum).EntireRow.Hidden = True
End If
End If
If mask Like "Item 10" Then
If Application.WorksheetFunction.CountA(Range("J" & RunningNum & ":S" & RunningNum)) > 0 Then
Sheets("Output").Rows(RunningNum).EntireRow.Hidden = True
End If
End If
Next
End Sub````
But I have Filters on all the Headers, was wondering if it'd be smarter to use the Filters rather than the above code!
If so, where would I look at to play around with filters?

Related

Excel VBA Multiple if statement in loop working incorrectly

Sorry in advance if this has been covered already, I did try to look around first.
I have multiple if statements inside a loop and the conditions of the if statements are not being adhered to. I am working on fluid flow through pipe and the conditions for my calculation change with which range of numbers the reynolds number is between.
no-slip Reynolds < 2000 is laminar
no-slip Reynolds > 4000 is turbulent
between is transition
I have all three conditions in their own columns and the if statements should choose the correct one based on the Reynolds number and goes down all of the rows in the sheet.
For i = 6 To rows + 6 Step 1
If Range("BQ" & i).Value <=2000 Then
Range("BV" & i).Value = Range("BR" & i).Value
End If
If Range("BQ" & i).Value >= 4000 Then
Range("BV" & i).Value = Range("BT" & i).Value
End If
If 2000 < Range("BQ" & i).Value < 4000 Then
Range("BV" & i).Value = Range("BU" & i).Value
End If
Next i
RESULT:
Excel sheet
As you can see the Fns column is being filled by Fns Transition even though the reynolds number is under 2000.
Bringing this down from my comment:
2000 < Range("BQ" & i).Value AND Range("BQ" & i).Value < 4000 instead. Otherwise you end up with one half of that inequality range being solved for (True < 4000) and then the resulting boolean being compared with 4000, which will always be True (I think). Also, instead of separate if you should be using elseif in here since only one of these conditions should be true at a time.
For i = 6 To rows + 6 Step 1
If Range("BQ" & i).Value <=2000 Then
Range("BV" & i).Value = Range("BR" & i).Value
ElseIf Range("BQ" & i).Value >= 4000 Then
Range("BV" & i).Value = Range("BT" & i).Value
ElseIf 2000 < Range("BQ" & i).Value AND Range("BQ" & i).Value < 4000 Then
Range("BV" & i).Value = Range("BU" & i).Value
End If
Next i
You might have more luck with a Select Case statement:
Select Case Range("BQ" & i).Value
Case Is <= 2000
Range("BV" & i).Value = Range("BR" & i).Value
Case Is >= 4000
Range("BV" & i).Value = Range("BT" & i).Value
Case Else
Range("BV" & i).Value = Range("BU" & i).Value
End Select
This is easier to read and debug later as well.
Or an Excel formula could do this:
=SWITCH(true,BQ2<=2000,BV2,BQ2>=4000,BT2,BU2)

VBA - IFELSE and Continuous Looping

I want to have 2 formulas with continuous looping as long as there is value in the cell next to the targeted cell, thus i need to have ifelse function but with continuous looping aswell. for now i don't know how to insert the second formula.
Range("D9").Select
Set ws = Sheets("LAP KEL BIAYA")
lastRow = ws.Range("C" & Rows.Count).End(xlUp).Row
With ws
For i = 9 To lastRow
If Len(Trim(.Range("C" & i).Value)) <> 0 Then
Function Total(Text, Number)
.Range("D" & i).Formula = "=IF(RC[-3]=""B"",IF(AND(R4C3>0,R5C3>0),SUMIFS(FBL3N!C[11],FBL3N!C[21],R4C3,FBL3N!C[22],R5C3,FBL3N!C[16],R7C4,FBL3N!C[47],RC[-1]),IF(AND(R4C3>0,R5C3=""""),SUMIFS(FBL3N!C[11],FBL3N!C[21],R4C3,FBL3N!C[16],R7C4,FBL3N!C[47],'LAP KEL BIAYA'!RC[-1]),IF(AND(R4C3=0,R5C3>0),SUMIFS(FBL3N!C[11],FBL3N!C[22],R5C3,FBL3N!C[16],R7C4,FBL3N!C[47],RC[-1]),IF(AND(R4C3=0,R5C3=0),SUMIFS(F" & _
"BL3N!C[11],FBL3N!C[16],R7C4,FBL3N!C[47],RC[-1]),"""")))))" & _
""
ElseIf Total = "False" Then
If Len(Trim(.Range("C" & i).Value)) <> 0 Then
.Range("D" & i).Formula = "=IF(AND(R4C3>0,R5C3>0,OR(R[-1]C1=""7"",R[-1]C1=""5"",R[-1]C1=""4"")),SUMIFS(FBL3N!C[11],FBL3N!C[21],R4C3,FBL3N!C[22],R5C3,FBL3N!C[16],R7C4,FBL3N!C,R[-1]C[-1]),IF(AND(R4C3>0,R5C3=0),SUMIFS(FBL3N!C[11],FBL3N!C[21],R4C3,FBL3N!C[16],R7C4,FBL3N!C,'LAP KEL BIAYA'!R[-1]C[-1]),IF(AND(R4C3=0,R5C3>0),SUMIFS(FBL3N!C[11],FBL3N!C[22],R5C3,FBL3N!C[16],R7C4,FBL3N!C,R[-1]C[-1]),IF(" & _
"AND(R4C3=0,R5C3=0),SUMIFS(FBL3N!C[11],FBL3N!C[16],R7C4,FBL3N!C,R[-1]C[-1])))))" & _
""
.Range("D" & i).Font.Color = vbRed
End If
Next i
End Function
End With

Arraylist checks for columns in Pivot Table - ActiveSheet Range results in object defined error if any one column does not exist

The code below does the following:
It has a preset list of Column Header Names (Origin Country, Origin Handling, Truck Cost etc, i = 1 to 9) that it will match against a pivot table and assign a column header designation. e.g. Origin Country is Column B, Origin Handling Cost is Column C.
It will then compare the rows in the pivot table based on a preset strformula by checking if B4 = B5 then C4 = C5. In case of an error it will highlight the cells.
The code works like a charm if all column headers are found however whenever a column/header (e.g. Truck cost) is missing from the pivot table and instead of a match e.g. strOCountryCol = "G" I get Origin Truck = "empty" then the Active Sheet.Range code results in an object defined error (1004).
I have been wrecking my head why On Error Resume next will not just move on to the next i.
This is the line of the code where the debug error occurs:
Origin_Str_List(1) = strOHandlingMCol: Origin_Str_List(2) = strExCustomCol: Origin_Str_List(3) = strOHandlingPerCol:
Origin_Str_List(4) = strOHandlingPerShipCol: Origin_Str_List(5) = strOTHCMinCol: Origin_Str_List(6) = strOTHCPerCol:
Origin_Str_List(7) = strOOtherMinCol:
Origin_Str_List(8) = strOOtherPerCol: Origin_Str_List(9) = strOOtherPerShipCol
Origin_Col_List(1) = OHandlingMCol: Origin_Col_List(2) = ExCustomCol: Origin_Col_List(3) = OHandlingPerCol:
Origin_Col_List(4) = OHandlingPerShipCol: Origin_Col_List(5) = OTHCMinCol: Origin_Col_List(6) = OTHCPerCol:
Origin_Col_List(7) = OOtherMinCol:
Origin_Col_List(8) = OOtherPerCol: Origin_Col_List(9) = OOtherPerShipCol
On Error Resume Next
For i = 1 To 9
strFormula = "=AND($" & strOCountryCol & HeaderRow + 1 & "=$" & strOCountryCol & HeaderRow + 2 & ls & "$" _
& strOAirportCol & HeaderRow + 1 & "=$" & strOAirportCol & HeaderRow + 2 _
& ls & "$" & Origin_Str_List(i) & HeaderRow + 1 & "<>$" & Origin_Str_List(i) & HeaderRow + 2 & ls & "AND($" & Origin_Str_List(i) & HeaderRow + 1 & "<> ""(blank)""" & ls & "$" & Origin_Str_List(i) & HeaderRow + 1 & "<> ""-"" " & ls & Origin_Str_List(i) & HeaderRow + 1 & "<> 0))"
strFormula_rev = "=AND($" & strOCountryCol & HeaderRow + 2 & "=$" & strOCountryCol & HeaderRow + 1 & ls & "$" _
& strOAirportCol & HeaderRow + 2 & "=$" & strOAirportCol & HeaderRow + 1 _
& ls & "$" & Origin_Str_List(i) & HeaderRow + 2 & "<>$" & Origin_Str_List(i) & HeaderRow + 1 & ls & "AND($" & Origin_Str_List(i) & HeaderRow + 2 & "<> ""(blank)""" & ls & "$" & Origin_Str_List(i) & HeaderRow + 2 & "<> ""-"" " & ls & Origin_Str_List(i) & HeaderRow + 2 & "<> 0))"
With ActSht.Range(ActSht.Cells(HeaderRow + 1, Origin_Col_List(i)), ActSht.Cells(LastRow, Origin_Col_List(i)))
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:= _
strFormula
With .FormatConditions(.FormatConditions.Count)
.SetFirstPriority
With .Interior
.PatternColorIndex = xlAutomatic
.Color = RGB(255, 51, 0)
.TintAndShade = 0
End With
End With
End With
With ActSht.Range(ActSht.Cells(HeaderRow + 2, Origin_Col_List(i)), ActSht.Cells(LastRow, Origin_Col_List(i)))
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:= _
strFormula_rev
With .FormatConditions(.FormatConditions.Count)
.SetFirstPriority
With .Interior
.PatternColorIndex = xlAutomatic
.Color = RGB(255, 51, 0)
.TintAndShade = 0
End With
End With
End With
Next
in the picture below you can see where one array element is returned as empty. Yellow highlighted code is where debug stops with Object not Defined. The Origin_Col_List(i) has the value 4.
thanks for any pointers you can provide.

Excel multiple V look up formula pasted to used range by VBA

I need to summarise data from sheet5 into sheet9.
Sheet 5 has multiple rows of data with yearly and monthly data.
Sheet 9 has a list of ID's and Company names. No duplicates.
The matching ID is in column A of both sheets.
I need to summarise the data in sheet5 , by year , month and if there is any data added in sheet5 columns CS:DD.
I wanted to run a VBA code , that ask for year with an input box. Then based on that year. example if year was 2018
Match Column A sheet9 to Column A Sheet5
If Column D sheet5 = 2018 and Column E sheet5 = M1 and sheet5.Range("CS:DD") contains atleast 1 non blank cell. Then in column D on sheet5. Add yes. Else No. Column D would be for Jan (M1) Month 1.
Then same formula pasted in Column E based on if Column E = M2 , this would be for Feb , replicate this up to Dec.
I have first of all tried searching multiple VBLook Up formulas , but could not find a solution
Sub Progress()
Dim x
Dim y
Dim tabl As ListObject
Set tabl = Sheet5.ListObjects(1)
Dim orgid As String
Dim yearchoice As Variant
yearchoice = InputBox("Enter year to filter by format is 2019", "Select Year")
Dim lrow1, lrow6
tabl.AutoFilter.ShowAllData
tabl.Range.AutoFilter Field:=4, Criteria1:=yearchoice
lrow1 = Sheet5.Cells(Rows.Count, 1).End(xlUp).Row
lrow6 = Sheet6.Cells(Rows.Count, 1).End(xlUp).Row
For x = 2 To lrow6
orgid = Sheet6.Range("A" & x).Value
For y = 2 To lrow1
If Sheet5.Range("A" & y).Value = orgid And Sheet5.Range("E" & x).Value = "M1" And WorksheetFunction.CountA(Sheet5.Range("CS" & y & ":DD" & y).Value) > 0 Then Sheet6.Range("D" & x).Value = "YES": GoTo found
If Sheet5.Range("A" & y).Value = orgid And Sheet5.Range("E" & x).Value = "M2" And WorksheetFunction.CountA(Sheet5.Range("CS" & y & ":DD" & y).Value) > 0 Then Sheet6.Range("E" & x).Value = "YES": GoTo found
If Sheet5.Range("A" & y).Value = orgid And Sheet5.Range("E" & x).Value = "M3" And WorksheetFunction.CountA(Sheet5.Range("CS" & y & ":DD" & y).Value) > 0 Then Sheet6.Range("F" & x).Value = "YES": GoTo found
If Sheet5.Range("A" & y).Value = orgid And Sheet5.Range("E" & x).Value = "M4" And WorksheetFunction.CountA(Sheet5.Range("CS" & y & ":DD" & y).Value) > 0 Then Sheet6.Range("G" & x).Value = "YES": GoTo found
If Sheet5.Range("A" & y).Value = orgid And Sheet5.Range("E" & x).Value = "M5" And WorksheetFunction.CountA(Sheet5.Range("CS" & y & ":DD" & y).Value) > 0 Then Sheet6.Range("H" & x).Value = "YES": GoTo found
If Sheet5.Range("A" & y).Value = orgid And Sheet5.Range("E" & x).Value = "M6" And WorksheetFunction.CountA(Sheet5.Range("CS" & y & ":DD" & y).Value) > 0 Then Sheet6.Range("I" & x).Value = "YES": GoTo found
If Sheet5.Range("A" & y).Value = orgid And Sheet5.Range("E" & x).Value = "M7" And WorksheetFunction.CountA(Sheet5.Range("CS" & y & ":DD" & y).Value) > 0 Then Sheet6.Range("J" & x).Value = "YES": GoTo found
If Sheet5.Range("A" & y).Value = orgid And Sheet5.Range("E" & x).Value = "M8" And WorksheetFunction.CountA(Sheet5.Range("CS" & y & ":DD" & y).Value) > 0 Then Sheet6.Range("K" & x).Value = "YES": GoTo found
If Sheet5.Range("A" & y).Value = orgid And Sheet5.Range("E" & x).Value = "M9" And WorksheetFunction.CountA(Sheet5.Range("CS" & y & ":DD" & y).Value) > 0 Then Sheet6.Range("L" & x).Value = "YES": GoTo found
If Sheet5.Range("A" & y).Value = orgid And Sheet5.Range("E" & x).Value = "M10" And WorksheetFunction.CountA(Sheet5.Range("CS" & y & ":DD" & y).Value) > 0 Then Sheet6.Range("M" & x).Value = "YES": GoTo found
If Sheet5.Range("A" & y).Value = orgid And Sheet5.Range("E" & x).Value = "M11" And WorksheetFunction.CountA(Sheet5.Range("CS" & y & ":DD" & y).Value) > 0 Then Sheet6.Range("N" & x).Value = "YES": GoTo found
If Sheet5.Range("A" & y).Value = orgid And Sheet5.Range("E" & x).Value = "M12" And WorksheetFunction.CountA(Sheet5.Range("CS" & y & ":DD" & y).Value) > 0 Then Sheet6.Range("O" & x).Value = "YES": GoTo found
found:
Next y
Next x
End Sub
This code froze on me , I was told a formula pasted in would be quicker

Excel VBA Replace characters in cells that contain html code

I have data in 3 different columns that I want to place in a column of cells that contain 22000 - 24000 characters of html code each. I was able to execute successfully with fewer characters in the column of cells that contain the html code. Is it possible to replace data in the column of cells that contain 22000 -24000 characters of html code each?
And I use a VBA program to do this.
Sub GoodREPLACETeleModule()
' <PUTDESCRIPTIONHERE>
For MY_ROWS = 1 To Range("AF" & Rows.Count).End(xlUp).Row
Range("R" & MY_ROWS).Value = Replace(Range("R" & MY_ROWS).Value, "PUTDESCRIPTIONHERE", Range("AF" & MY_ROWS).Value)
Next MY_ROWS
' <PUTIMAGEHERE>
For MY_ROWS = 1 To Range("AF" & Rows.Count).End(xlUp).Row
Range("P" & MY_ROWS).Value = Replace(Range("P" & MY_ROWS).Value, "PUTIMAGEHERE", Range("AF" & MY_ROWS).Value)
Next MY_ROWS
End Sub
I have "PUTIMAGEHERE" and "PUTDESCRIPTIONHERE" placed within the 24000 lines of html code but it does not reach it.
If you run the following, does the message box always say it is successful, even for characters greater than 24,000. If not, which data points fail exactly and at what point. You can review these data sets to verify that the overall length will not be greater than the limit.
Sub GoodREPLACETeleModule()
Dim wFind As Long
' <PUTDESCRIPTIONHERE>
For MY_ROWS = 1 To Range("AF" & Rows.Count).End(xlUp).Row
MsgBox "Row " & MY_ROWS
wFind = InStr(Range("R" & MY_ROWS).Value, "PUTDESCRIPTIONHERE")
If wFind = 0 Then
MsgBox "Nothing to replace"
Else
a = Len(Range("R" & MY_ROWS).Value): b = Len(Range("AF" & MY_ROWS).Value)
Range("R" & MY_ROWS).Value = Replace(Range("R" & MY_ROWS).Value, "PUTDESCRIPTIONHERE", Range("AF" & MY_ROWS).Value)
wFind = InStr(Range("R" & MY_ROWS).Value, "PUTDESCRIPTIONHERE")
If Not wFind = 0 Then MsgBox "Replace Failed"
If Len(Range("R" & MY_ROWS).Value) < a + b - Len("PUTDESCRIPTIONHERE") Then
MsgBox "The replace did not happen successfully"
Else
If Len(Range("R" & MY_ROWS).Value) > 32766 then
Msgbox "Too many characters"
Else
MsgBox "Replace succeeded, old string was " & a & " characters, new string is " & Len(Range("R" & MY_ROWS).Value) & " characters."
End If
End If
End If
Next MY_ROWS
' <PUTIMAGEHERE>
For MY_ROWS = 1 To Range("AF" & Rows.Count).End(xlUp).Row
MsgBox "Row " & MY_ROWS
wFind = InStr(Range("P" & MY_ROWS).Value, "PUTIMAGEHERE")
If wFind = 0 Then
MsgBox "Nothing to replace"
Else
a = Len(Range("R" & MY_ROWS).Value): b = Len(Range("AF" & MY_ROWS).Value)
Range("P" & MY_ROWS).Value = Replace(Range("P" & MY_ROWS).Value, "PUTIMAGEHERE", Range("AF" & MY_ROWS).Value)
wFind = InStr(Range("P" & MY_ROWS).Value, "PUTIMAGEHERE")
If Not wFind = 0 Then MsgBox "Replace Failed"
If Len(Range("P" & MY_ROWS).Value) < a + b - Len("PUTIMAGEHERE") Then
MsgBox "The replace did not happen successfully"
Else
If Len(Range("P" & MY_ROWS).Value) > 32766 then
Msgbox "Too many characters"
Else
MsgBox "Replace succeeded, old string was " & a & " characters, new string is " & Len(Range("P" & MY_ROWS).Value) & " characters."
End If
End If
End If
Next MY_ROWS
End Sub
Unfortunately there are Excel Limits
as to how many characters can be contained in a cell.

Resources