Delete columns/rows when doesn't contain values from varLists - excel

I am new to VBA... I am trying delete all columns from Sheet1:"Template" ROW1/headers file that doesn't match any of the cell values on varList:"ColumnsList" (that is in Sheet3).
How do I select the headers or how do I select the row 1 range to search into?
Also, I have a runtime error 5 in this line: invalid procedure call or argument.
If Intersect(rng.Cells(1, i).EntireColumn, rngF) Is Nothing Then
Any kind soul that help me with that please?
Also, I need to do the same but with rows from Sheet1:"Template". I need to delete any row that doesn't CONTAIN any cell value from varList:"Agents" (that is in Sheet2).
Could you please help me out?
Maaaany thanks in advance!!!
Option Compare Text
Sub ModifyTICBData()
Dim varList As Variant
Dim lngarrCounter As Long
Dim rngFound As Range, rngToDelete As Range
Dim strFirstAddress As String
'Application.ScreenUpdating = False
varList = VBA.Array("ColumnsList") 'I want to keep columns with these values, NOT DELETE THEM
For lngarrCounter = LBound(varList) To UBound(varList)
With Sheets("Template").UsedRange
Set rngFound = .Find( _
What:=varList(lngarrCounter), _
Lookat:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=True)
If Not rngFound Is Nothing Then
strFirstAddress = rngFound.Address
If rngToDelete Is Nothing Then
Set rngToDelete = rngFound
Else
If Application.Intersect(rngToDelete, rngFound.EntireColumn) Is Nothing Then
Set rngToDelete = Application.Union(rngToDelete, rngFound)
End If
End If
Set rngFound = .FindNext(After:=rngFound)
Do Until rngFound.Address = strFirstAddress
If Application.Intersect(rngToDelete, rngFound.EntireColumn) Is Nothing Then
Set rngToDelete = Application.Union(rngToDelete, rngFound)
End If
Set rngFound = .FindNext(After:=rngFound)
Loop
End If
End With
Next lngarrCounter
Dim rngDel As Range
Set rngDel = NotIntersectRng(Sheets("Template").UsedRange, rngToDelete)
If Not rngDel Is Nothing Then rngDel.EntireColumn.delete
'Application.ScreenUpdating = True
End Sub
Private Function NotIntersectRng(rng As Range, rngF As Range) As Range
Dim rngNI As Range, i As Long, j As Long
For i = 1 To rng.Columns.Count
**If Intersect(rng.Cells(1, i).EntireColumn, rngF) Is Nothing Then**
If rngNI Is Nothing Then
Set rngNI = rng.Cells(1, i)
Else
Set rngNI = Union(rngNI, rng.Cells(1, i))
End If
End If
Next i
If Not rngNI Is Nothing Then Set NotIntersectRng = rngNI
End Function

Delete Columns, Then Rows
Description
Deletes columns that in the first row do not contain values from a list. Then deletes rows that in the first column do not contain values from another list.
The Flow
Writes the values from range A2 to the last cell in Sheet3 to the Cols Array.
Writes the values from range A2 to the last cell in Sheet2 to the Agents Array.
Using CurrentRegion defines the DataSet Range (rng).
Loops through the cells (cel) in first row starting from the 2nd column and compares their values to the values from the Cols Array. If not found adds the cells to the Delete Range(rngDel).
Finally deletes the entire columns of the cells 'collected'.
Loops through the cells (cel) in first column starting from the 2nd row and compares their values to the values from the Agents Array. If not found adds the cells to the Delete Range(rngDel).
Finally deletes the entire rows of the cells 'collected'.
Informs the user of success or no action.
The Code
Option Explicit
Sub ModifyTICBData()
' Define workbook ('wb').
Dim wb As Workbook
Set wb = ThisWorkbook
' Define Columns List ('Cols').
Dim ws As Worksheet
Set ws = wb.Worksheets("Sheet3")
Dim rng As Range
Set rng = ws.Cells(ws.Rows.Count, "A").End(xlUp)
Dim Cols As Variant
Cols = ws.Range("A2", rng).Value
' Define Agents List ('Agents').
Set ws = wb.Worksheets("Sheet2")
Set rng = ws.Cells(ws.Rows.Count, "A").End(xlUp)
Dim Agents As Variant
Agents = ws.Range("A2", rng).Value
' Define DataSet Range ('rng').
Set rng = wb.Worksheets("Template").Range("A1").CurrentRegion
Application.ScreenUpdating = False
' Define Delete Range ('rngDel') for Columns.
Dim rngDel As Range
Dim cel As Range
For Each cel In rng.Rows(1).Resize(, rng.Columns.Count - 1) _
.Offset(, 1).Cells
If IsError(Application.Match(cel.Value, Cols, 0)) Then
collectCells rngDel, cel
End If
Next cel
' Delete Columns.
Dim AlreadyDeleted As Boolean
If Not rngDel Is Nothing Then
rngDel.EntireColumn.Delete
Else
AlreadyDeleted = True
End If
' Define Delete Range ('rngDel') for Agents.
Set rngDel = Nothing
For Each cel In rng.Columns("A").Resize(rng.Rows.Count - 1) _
.Offset(1).Cells
If IsError(Application.Match(cel.Value, Agents, 0)) Then
collectCells rngDel, cel
End If
Next cel
' Delete Agents (Rows).
If Not rngDel Is Nothing Then
rngDel.EntireRow.Delete
AlreadyDeleted = False
End If
Application.ScreenUpdating = True
' Inform user
If Not AlreadyDeleted Then
MsgBox "The data was succesfully deleted.", vbInformation, "Success"
Else
MsgBox "The data had already been deleted.", vbExclamation, "No Action"
End If
End Sub
Sub collectCells(ByRef CollectRange As Range, CollectCell As Range)
If Not CollectCell Is Nothing Then
If Not CollectRange Is Nothing Then
Set CollectRange = Union(CollectRange, CollectCell)
Else
Set CollectRange = CollectCell
End If
End If
End Sub

Related

How can I stop my vba code from giving me an error 424?

I've written a code that does many things. Essentially it loops through each worksheets starting with MW, in these sheets, it deletes some columns, does some operations and changes some column names. Right now, The code works, but after adding the loop through worksheets, I get an error 424 on the "If not Rng Is Nothing Then Rng.EntireColumn.Delete"
How can I fix this?
My theory is that my ws loop doesn't work well, so the code can't work since the sheet is already processed
Here's my code
Dim Cl As Range, Rng As Range
Dim Cl2 As Range, Rng2 As Range
Dim Cl3 As Range, Rng3 As Range
Dim c As Range
Dim Cl4 As Range, Rng4 As Range
Dim Lastrow As Long
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.Name Like "MW*" Then
For Each Cl In Range("A1:J1")
Select Case Cl.Value
Case "#", "Coupler Detached", "Coupler Attached", "Host Connected", "End Of File", "ms"
If Rng Is Nothing Then Set Rng = Cl Else Set Rng = Union(Rng, Cl)
End Select
Next Cl
If Not Rng Is Nothing Then Rng.EntireColumn.Delete
For Each Cl4 In Range("D1")
Select Case Cl4.Value
Case "Abs Pres (kPa) c:1 2"
If Rng4 Is Nothing Then Set Rng4 = Cl4 Else Set Rng4 = Union(Rng4, Cl4)
End Select
Next Cl4
If Not Rng4 Is Nothing Then
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "D").End(xlUp).Row
For Each c In Range("D2:D" & Lastrow)
c.Value = c.Value * 0.101972
Next
Application.ScreenUpdating = True
End If
For Each Cl2 In Range("A1:J1")
Select Case Cl2.Value
Case "Abs Pres (kPa) c:1 2"
If Rng2 Is Nothing Then Set Rng2 = Cl2 Else Set Rng = Union(Rng, Cl2)
End Select
Next Cl2
If Not Rng2 Is Nothing Then Rng2.Value = ("LEVEL")
For Each Cl3 In Range("A1:J1")
Select Case Cl3.Value
Case "Temp (°C) c:2"
If Rng3 Is Nothing Then Set Rng3 = Cl3 Else Set Rng = Union(Rng, Cl3)
End Select
Next Cl3
If Not Rng3 Is Nothing Then Rng3.Value = ("TEMPERATURE")
End If
Next ws
Object Variables in Loops
The main issue was that you cannot combine cells with an invalid range so you need to 'reset' the rng* variables i.e. explicitly set them to nothing. For example, in the first iteration, there were cells combined into rng. Now you delete rng and the variable's state is still Not Nothing although you have deleted the range making it invalid. In the next iteration, you try to combine this invalid range (which is Not Nothing) with a matching cell via Union so the error occurs. BTW, even if you didn't delete the range, again, an error would occur because you cannot combine ranges from different worksheets.
In the following code, pay attention to how this (Set rng = Nothing) is done after each stage per worksheet when only a single rng variable is used.
Also, note how ws and cell are 'safe', they don't need to be reset, since For Each... could be translated as something like Set ws = WhatEverWorksheet or Set cell = WhatEverCell.
Sub ALot()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' If it's not, change back to 'ActiveWorkbook'.
Application.ScreenUpdating = False
Dim ws As Worksheet, rng As Range, cell As Range
For Each ws In wb.Worksheets
If ws.Name Like "MW*" Then
' Delete columns.
For Each cell In ws.Range("A1:J1").Cells
Select Case CStr(cell.Value)
Case "#", "Coupler Detached", "Coupler Attached", _
"Host Connected", "End Of File", "ms"
If rng Is Nothing Then Set rng = cell Else Set rng = Union(rng, cell)
End Select
Next cell
If Not rng Is Nothing Then
rng.EntireColumn.Delete
Set rng = Nothing ' reset
End If
' Check 4th column.
Set cell = ws.Range("D1")
If CStr(cell.Value) = "Abs Pres (kPa) c:1 2" Then
Set rng = ws.Range("D2", ws.Cells(ws.Rows.Count, "D").End(xlUp))
rng.Value = ws.Evaluate(rng.Address & "*0.101972")
Set rng = Nothing ' reset
End If
' Check "Abs Pres (kPa) c:1 2".
For Each cell In ws.Range("A1:J1").Cells
Select Case CStr(cell.Value)
Case "Abs Pres (kPa) c:1 2"
If rng Is Nothing Then Set rng = cell Else Set rng = Union(rng, cell)
End Select
Next cell
If Not rng Is Nothing Then
rng.Value = "LEVEL"
Set rng = Nothing ' reset
End If
' Check "Temp (°C) c:2".
For Each cell In ws.Range("A1:J1").Cells
Select Case cell.Value
Case "Temp (°C) c:2"
If rng Is Nothing Then Set rng = cell Else Set rng = Union(rng, cell)
End Select
Next cell
If Not rng Is Nothing Then
rng.Value = "TEMPERATURE"
Set rng = Nothing ' reset
End If
'Else ' is not like "MW*"; do nothing
End If
Next ws
Application.ScreenUpdating = True
MsgBox "Worksheets processed.", vbInformation
End Sub

FindNext property of Range Object cannot be assigned

I have written a code, which includes the FindNext method. All the code works so far, only when it gets to the FindNext method it shows an error saying the FindNext Object cannot be assigned.
However, I don't see where the Range Object (in this case "cell") is changed in any way for the FindNext method to not be able to assign it. Has anybody got an idea?
Please ignore any chunky written code, I'm very new with VBA ;)
Sub Search()
Dim wks As Worksheet
Set wks = ActiveSheet
Dim cell As Range, sngCell As Range
Dim Count As Long
Dim firstCell As String
Dim rg As Range, lastColumn As Long
Set cell = wks.Cells.Find(what:="Planned Supply at BP|SL (EA)", LookIn:=xlValues, lookat:=xlWhole)
firstCell = cell.Address
Do
With wks
lastColumn = .Cells(cell.Row, .Columns.Count).End(xlToLeft).Column
Set rg = Range(cell, .Cells(cell.Row, lastColumn))
End With
For Each sngCell In rg
If IsNumeric(sngCell.Value) = True Then
If sngCell.Value > 0 Then
If sngCell.Offset(-2, 0).Value > sngCell.Value Then
Count = Count + 1
End If
If Count = 0 Then
Rows(sngCell.Row - 2).Delete
Rows(sngCell.Row - 1).Delete
Rows(sngCell.Row).Delete
End If
End If
End If
Next
Set cell = wks.Cells.FindNext(cell)
Loop While cell.Address <> firstCell
End Sub
Find() in a loop is complex enough that it's worth splitting it out into a separate function. Here's a slightly different approach which reduces the complexity in your main Sub and allows you to focus on the business rules instead of the nuances of using Find()
Sub Search()
Dim wks As Worksheet
Dim cell As Range, sngCell As Range
Dim firstCell As String
Dim rg As Range, lastColumn As Long, matches As Collection
Set wks = ActiveSheet
Set matches = FindAll(wks.Cells, "Planned Supply at BP|SL (EA)")
For Each cell In matches
Debug.Print "Found:", cell.Address
Set rg = wks.Range(cell, wks.Cells(cell.Row, Columns.Count).End(xlToLeft))
For Each sngCell In rg.Cells
If IsNumeric(sngCell.Value) Then 'no need for `= True`
If sngCell.Value > 0 Then
If sngCell.Offset(-2, 0).Value <= sngCell.Value Then
sngCell.Offset(-2, 0).Resize(3).EntireRow.Delete
Exit For 'stop checking...
End If
End If
End If
Next
Next cell
End Sub
'Find all matches for `val` in `rng` and return as a collection
Public Function FindAll(rng As Range, val As String) As Collection
Dim rv As New Collection, f As Range, addr As String
Set f = rng.Find(what:=val, after:=rng.Cells(rng.Cells.CountLarge), _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If Not f Is Nothing Then addr = f.Address()
Do Until f Is Nothing
rv.Add f
Set f = rng.FindNext(after:=f)
If f.Address() = addr Then Exit Do
Loop
Set FindAll = rv
End Function

How would I loop this Function over column Q with VBA?

I have the following code and it does what I want it to as far as removing the data I want to remove. The only thing is I have to run it over and over and over for it to get through all of the data. How would I get this to loop over just column q?
Sub SdeleteDeclinesfoReal()
Dim sString As String
Dim MyAr
Dim i As Long
Dim delRange As Range, aCell As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
'~~> Add more to the list here separated by "/"
sString = "Declined/Self ACH"
MyAr = Split(sString, "/")
With ws
For i = LBound(MyAr) To UBound(MyAr)
Set aCell = .Columns(17).Find(What:=MyAr(i), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase :=False, SearchFormat:=False)
If Not aCell Is Nothing Then
If delRange Is Nothing Then
Set delRange = .Rows(aCell.Row)
Else
Set delRange = Union(delRange, .Rows(aCell.Row))
End If
End If
Next i
End With
'...
End Sub
Loop Through Column
A Find Method Solution
Option Explicit
Sub SdeleteDeclinesfoReal()
Const FirstRow As Long = 2
Const CritCol As String = "Q"
Dim Criteria As Variant
'~~> Add more to the list here
Criteria = Array("Declined", "Self ACH")
Dim ws As Worksheet
Dim rng As Range, delRange As Range, aCell As Range
Dim i As Long
Dim sString As String
Dim FirstAddress As String
Set ws = ThisWorkbook.Sheets("Sheet1")
' Define range "Q2:Q1048576" (FirstRow, CritCol).
Set rng = ws.Cells(FirstRow, CritCol).Resize(ws.Rows.Count - FirstRow + 1)
' Define last non-blank cell.
Set rng = rng.Find(What:="*", _
LookIn:=xlValues, _
SearchDirection:=xlPrevious)
If Not rng Is Nothing Then
' Define 'non-blank' range.
Set rng = ws.Cells(FirstRow, CritCol).Resize(rng.Row - FirstRow + 1)
With rng
For i = LBound(Criteria) To UBound(Criteria)
sString = Criteria(i)
Set aCell = .Find(What:=sString, _
LookAt:=xlWhole)
If Not aCell Is Nothing Then
FirstAddress = aCell.Address
Do
If delRange Is Nothing Then
Set delRange = aCell.EntireRow
Else
Set delRange = Union(delRange, aCell.EntireRow)
End If
Set aCell = .FindNext(aCell)
' Prevent infinite loop caused by the 'FindNext' method.
Loop Until aCell.Address = FirstAddress
Else
' Criteria not found.
End If
' Prevent infinite loop when a criteria is found and one
' of the next is not.
Set aCell = Nothing
Next i
End With
If Not delRange Is Nothing Then
delRange.Select ' Test with 'Select'. Later change to 'Delete'.
Else
' Nothing cell found.
End If
Else
' All cells below first row are blank (empty or "").
End If
End Sub
A Reminder Why to Use Union
Copy the examples into a standard module, e.g. Module1 of a new workbook.
The first two procedures show how to increase efficiency using an array, but are primarily here to better understand what the last three procedures do.
Run the trio each after populating the values, and monitor how long they take and look at the ActiveSheet before and after to see the differences.
Test Union
Option Explicit
' Slow
Sub populateValuesSlow()
Const NoR As Long = 5000
Const NoC As Long = 10
Dim i As Long
Dim j As Long
For i = 1 To NoR
For j = 1 To NoC
Cells(i, j) = Int(Rnd() * (10 - 1)) + 1
Next j
Next i
End Sub
' Fast
Sub populateValuesFast()
Const NoR As Long = 5000
Const NoC As Long = 10
Dim i As Long
Dim j As Long
Dim Data As Variant
ReDim Data(1 To NoR, 1 To NoC)
For i = 1 To NoR
For j = 1 To NoC
Data(i, j) = Int(Rnd() * (10 - 1)) + 1
Next j
Next i
Cells(1, 1).Resize(UBound(Data, 1), UBound(Data, 2)).Value = Data
End Sub
' Wrong: in this case, half of the data still remains.
Sub deleteRowsOneRowAtTheTimeWrong()
Const NoR As Long = 5000
Dim i As Long
For i = 1 To NoR
Rows(i).Delete
Next i
End Sub
' Right but Slow
Sub deleteRowsOneRowAtTheTime()
Const NoR As Long = 5000
Dim i As Long
For i = NoR To 1 Step -1
Rows(i).Delete
Next i
End Sub
' Right and Fast
Sub deleteRowsWithUnion()
Const NoR As Long = 5000
Dim rng As Range
Dim i As Long
For i = 1 To NoR
If Not rng Is Nothing Then
Set rng = Union(rng, Rows(i))
Else
Set rng = Rows(i)
End If
Next i
rng.Delete
End Sub
Well let me describe your scenary:
You have a list in this case your list is
sString = "Declined/Self ACH" (for this example your list have 2 elements)
then you have a table that have at least 17 columns ( Set aCell = .Columns(17).Find) and with your program you search all rows that have in column 17 a value that is in your list then put all that "rows" in a range (delRange) and delete all rows in that range
In this point your code only find firts match for each element in your list so you Range (delRange) have maximum size equal maximum size your list (for this example 2).
OK for me:
Why you save a range with elements that you are going to delete?
you can insert a delete instruction in second loop that others user suggest you, but instead use .Findnext you use another .find
PO=17 /*PO is whatever column you want*/
For i = LBound(MyAr) To UBound(MyAr)
Set aCell = .Columns(PO).Find(What:=MyAr(i), LookIn:=xlValues)
If Not aCell Is Nothing Then
Do
.Rows(aCell.Row).Delete
Set aCell = .Columns(PO).Find(What:=MyAr(i), LookIn:=xlValues)
Loop While Not aCell Is Nothing
End If
Next i

VBA Multiple value find and replace but also highlight replaced cells

I have a code that finds and replaces values in one sheet from a list in another sheet. However, I need this code to also highlight the cell, or flag it in some way so that it can be reviewed manually later. Any suggestions?
Here is the code:
Sub ReplaceValues()
Dim FandR As Worksheet
Dim PDH As Worksheet
Dim rng As Range, rngR As Range
Dim i As Long
Dim rngReplacement
Dim c As Range
Dim curVal As String
Set FandR = Sheets("Find and Replace")
Set PDH = ThisWorkbook.Sheets("Paste Data here")
i = PDH.Rows.Count
With PDH
Set rng = .Range("E1", .Range("E" & i).End(xlUp))
End With
With FandR
Set rngR = FandR.Range("H")
End With
For Each c In rngR
curVal = c.Value
c.Interior.Color = vbYellow
With rng
.Replace curVal, c.Offset(0, 1).Value, xlWhole, , True
End With
Next
End Sub

VBA Nested If / range match

I have a pretty large excel file that houses a list of employees, a few columns of paycheck data, then a fiscal week assigned to when that data was collected.
I am trying to search though this data and match an employee with a specific fiscal week in a macro. I have a solution that finds the name, but wont print out the fiscal week and it is very slow and I'm sure that there are much better ways of doing this simple task. Below is what I have, it's pretty simple and in the end I will need to capture the data in the rows but for now I am just printing to have proof of concept.
Sub loop_test()
Dim ClientTable As Range
Dim rng1 As Range, rng2 As Range, desired_emp As String, desired_fw As Integer
desired_emp = Application.InputBox("Select an Employee", Type:=8)
desired_fw = Application.InputBox("What FW would you like to do this for?", Type:=8)
Set FullName = Sheets("Query5").Range("A:A")
Set FiscalWeek = Sheets("Query5").Range("F:F")
For Each rng1 In FullName.Columns(1).Cells
If rng1.Value = desired_emp Then
matched_name = rng1.Cells.Value
For Each rng2 In FullName.Columns(1).Cells
If rng2.Value = desired_fw Then
matched_fw = rng2.Cells.Value
End If
Next
End If
Next
Range("i3").Value = matched_name
Range("j3").Value = matched_fw
End Sub
I set up an example range with names and fiscal weeks in columns A and B. Modify the code below to match the columns and range in your workbook, and set the target sheet to the appropriate place.
This code autofilters your range based on user inputs and copies the results to another sheet if there is a match:
Sub Autofilter_test()
Dim clientTable As Range
Dim desired_emp As String
Dim desired_fw As Integer
Dim MatchRange As Range
Dim tgt As Worksheet
Set clientTable = Range("A1:B8")
Set tgt = ThisWorkbook.Sheets("Sheet2")
ActiveSheet.AutoFilterMode = False
desired_emp = Application.InputBox("Select an Employee")
desired_fw = Application.InputBox("What FW would you like to do this for?")
With clientTable
.AutoFilter Field:=1, Criteria1:=desired_emp
.AutoFilter Field:=2, Criteria1:=desired_fw
End With
Call CopyFilteredData(tgt)
End Sub
Sub CopyFilteredData(tgt As Worksheet)
' by Tom Ogilvy source: http://www.contextures.com/xlautofilter03.html
Dim rng As Range
Dim rng2 As Range
With ActiveSheet.AutoFilter.Range
On Error Resume Next
Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
If rng2 Is Nothing Then
MsgBox "No data to copy"
Else
tgt.Cells.Clear
Set rng = ActiveSheet.AutoFilter.Range
rng.Offset(1, 0).Resize(rng.Rows.Count - 1).Copy _
Destination:=tgt.Range("A1")
End If
ActiveSheet.ShowAllData
End Sub

Resources