Related
I'm working on a loop that will feed of a cell in sheet "Results" and go through number of worksheets (at the moment set to 1-3) and delete the row where it finds the value from sheet "Results". At the moment it fails, can you please advise?
Sub Del_Rows()
Dim rng As Range, cell As Range, del As Range
Dim sht As Worksheet
For x = 1 To 3
Set sht = Sheets(x)
Set del = Sheets("Results").Range("A13")
Set rng = Intersect(sht.Range("A1:A2000"), sht.UsedRange)
For Each cell In rng.Cells
If (cell.Value) = Sheets("Results").Range("A13") Then
If del Is Nothing Then
Set del = cell
Else
Set del = Union(del, cell)
End If
End If
Next cell
If del Is del Then del.EntireRow.Delete
Next x
End Sub
Also, I understand it might be a lot trickier to do but is it possible for the code to have a look at the dynamic range in sheet("Results") one by one?
What I mean is e.g. the code takes the value of Sheets("Results").Range("A13") and does the search for the value across the sheets 1-3 deleting rows when it finds it, and then it moves to Sheets("Results").Range("A14") and does the same thing.
Since the data in [Sheets("Results").Range("A13") + last row] is dynamic it simply does the same thing until it reaches the end (e.g. Sheets("Results").Range("A20").
Thanks a lot
I didn't test the code, so maybe there's some syntax error or typo.
Dim wb as workbook
Set wb = ActiveWorkbook
set rsws = wb.worksheets("Results")
dim lastResult as Long
lastResult = rsws.Usedrange.SpecialCells(xlCelltypeLastcell).Row 'count the last row of ResultSheet.
dim lastrowCheck as Long
for each ws in wb.worksheets 'loop through each worksheet
lastrowCheck = ws.Usedrange.SpecialCells(xlCelltypeLastcell).Row
if ws.name <> "Results" then
for i = 1 to lastResult 'loop through each Result range cell
for j = 1 to lastrowCheck 'loop throught and check value
if rsws.cells(i,13) <> vbNullString then
if rsws.cells(i,13) = ws.cells(j,1) then 'I suppose that it's in the first column.
'your deleting code here
end if
end if
next j
next i
end if
next ws
Below is the actual code in my excel which includes some debug print.
Sub testtesttest()
Dim wb As Workbook
Set wb = ActiveWorkbook
Set rsws = wb.Worksheets("Results")
Dim lastResult As Long
lastResult = rsws.UsedRange.SpecialCells(xlCellTypeLastCell).Row 'count the last row of ResultSheet.
Dim lastrowCheck As Long
For Each ws In wb.Worksheets 'loop through each worksheet
lastrowCheck = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row
Debug.Print "lastrowCheck "; lastrowCheck
Debug.Print ws.name
If ws.name <> "Results" Then
For i = 1 To lastResult 'loop through each Result range cell
For j = 1 To lastrowCheck 'loop throught and check value
If rsws.Cells(i, 13) = ws.Cells(j, 1) Then 'I suppose that it's in the first column.
'your deleting code here
Debug.Print "good good good"
End If
Next j
Next i
End If
Next ws
End Sub
I have managed to work on my initial code and came up with the following solution, which works for me.
Public Sub Loop_DEL()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'----------------------------------------------------------------------
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
'----------------------------------------------------------------------
Dim rng1 As Range, rng2 As Range, rng3 As Range, rng4 As Range, rng5 As Range, rng6 As Range, rng7 As Range, rng8 As Range, c As Range
Dim rngToDel2 As Range, rngToDel3 As Range, rngToDel4 As Range, rngToDel5 As Range, rngToDel6 As Range, rngToDel7 As Range, rngToDel8 As Range
Dim lastRow As Long
With Worksheets("Results")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng1 = .Range("A3:A" & lastRow)
End With
Set rng2 = Worksheets("ANY SCORE").Range("A:A")
Set rng3 = Worksheets("Page1").Range("A:A")
Set rng4 = Worksheets("Page2").Range("A:A")
Set rng5 = Worksheets("Page3").Range("A:A")
Set rng6 = Worksheets("Page4").Range("A:A")
Set rng7 = Worksheets("Page5").Range("A:A")
Set rng8 = Worksheets("Page6").Range("A:A")
For Each c In rng2
If Not IsError(Application.Match(c.Value, rng1, 0)) Then
If rngToDel2 Is Nothing Then
Set rngToDel2 = c
Else
Set rngToDel2 = Union(rngToDel2, c)
End If
End If
Next c
If Not rngToDel2 Is Nothing Then rngToDel2.EntireRow.Delete
For Each c In rng3
If Not IsError(Application.Match(c.Value, rng1, 0)) Then
If rngToDel3 Is Nothing Then
Set rngToDel3 = c
Else
Set rngToDel3 = Union(rngToDel3, c)
End If
End If
Next c
If Not rngToDel3 Is Nothing Then rngToDel3.EntireRow.Delete
For Each c In rng4
If Not IsError(Application.Match(c.Value, rng1, 0)) Then
If rngToDel4 Is Nothing Then
Set rngToDel4 = c
Else
Set rngToDel4 = Union(rngToDel4, c)
End If
End If
Next c
If Not rngToDel4 Is Nothing Then rngToDel4.EntireRow.Delete
For Each c In rng5
If Not IsError(Application.Match(c.Value, rng1, 0)) Then
If rngToDel5 Is Nothing Then
Set rngToDel5 = c
Else
Set rngToDel5 = Union(rngToDel5, c)
End If
End If
Next c
If Not rngToDel5 Is Nothing Then rngToDel5.EntireRow.Delete
For Each c In rng6
If Not IsError(Application.Match(c.Value, rng1, 0)) Then
If rngToDel6 Is Nothing Then
Set rngToDel6 = c
Else
Set rngToDel6 = Union(rngToDel6, c)
End If
End If
Next c
If Not rngToDel6 Is Nothing Then rngToDel6.EntireRow.Delete
For Each c In rng7
If Not IsError(Application.Match(c.Value, rng1, 0)) Then
If rngToDel7 Is Nothing Then
Set rngToDel7 = c
Else
Set rngToDel7 = Union(rngToDel7, c)
End If
End If
Next c
If Not rngToDel7 Is Nothing Then rngToDel7.EntireRow.Delete
For Each c In rng8
If Not IsError(Application.Match(c.Value, rng1, 0)) Then
If rngToDel8 Is Nothing Then
Set rngToDel8 = c
Else
Set rngToDel8 = Union(rngToDel8, c)
End If
End If
Next c
If Not rngToDel8 Is Nothing Then rngToDel8.EntireRow.Delete
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I'm trying to use this answer to apply my own sort of adding active cell address to a range so I can select the whole range later to a apply a conditional formatting. Below is my code but I'm not sure what is wrong. It came up with the error "Compile Error: Type Mismatch"
p/s: I have recorded my macro on this particular set of cells and then editted it.
Sub Macro1()
Dim rng2 As Range
Range("B3").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("D3").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("F3").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("H3").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("J3").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("L3").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("N3").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("P3").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("R3").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("R7").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("P7").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("N7").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("L7").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("J7").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("H7").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("F7").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("D7").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("B7").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("B11").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("D11").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("F11").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("J11").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range(rng2).Select
End Sub
Your first Set rng2 = Union(rng2, ActiveCell.Address) should be Set rng2 = ActiveCell. You cannot union to a range object that is nothing and rng2 is nothing until it is set to something so it cannot be part of the union statement.
Each subsequent Set rng2 = Union(rng2, ActiveCell.Address) should be Set rng2 = Union(rng2, ActiveCell). You cannot union to a range object's string address; you must union to a range object.
rng2 is now a valid range object and does not require further definition. Range(rng2).Select is invalid; simply use rng2.Select.
For all intents and purposes, you could have just stated,
Range("B3, D3, F3, H3, J3, L3, N3, P3, R3, R7, P7, N7, L7, J7, H7, F7, D7, B7, B11, D11, F11, J11").Select
You mentioned in a comment that you cut off your code due to space restrictions. Consider the following loop.
dim i as long, rng2 as range
Set rng2 = Range("B3, D3, F3, H3, J3, L3, N3, P3, R3")
For i = 7 To 23 Step 4
Set rng2 = Union(rng2, Intersect(rng2.EntireColumn, Rows(i)))
Next i
rng2.select
rng2.interior.color = vbred
Debug.Print rng2.Address(0, 0)
'B3,D3,F3,H3,J3,L3,N3,P3,R3,B7,D7,F7,H7,J7,L7,N7,P7,R7,B11,D11,F11,H11,J11,L11,N11,P11,R11,B15,D15,F15,H15,J15,L15,N15,P15,R15,B19,D19,F19,H19,J19,L19,N19,P19,R19,B23,D23,F23,H23,J23,L23,N23,P23,R23
The debug.print messages go to the VBE's Immediate window.
Sub test()
Dim MyCell As Range, i As Long
Dim SelectedRange As Range
Set SelectedRange = Application.InputBox("Select Range", Type:=8)
Dim SplitRow As Long
SplitRow = Application.InputBox("Split Row Num", Type:=1)
Dim FormatRange As Long
FormatRange = SelectedRange.Rows.Count / SplitRow
Application.ScreenUpdating = False
For Each MyCell In SelectedRange
If i < FormatRange Then
MyCell.Interior.Color = vbRed
i = i + 1
Else
MyCell.Interior.Color = vbYellow
End If
Next MyCell
Application.ScreenUpdating = True
End Sub
Sub test()
Dim selectedRange As Range, splitRow As Long, formatRange As Long, i As Long
Set selectedRange = Application.InputBox("Select Range", Type:=8)
splitRow = Application.InputBox("Split Row Num", Type:=1)
Application.ScreenUpdating = False
With selectedRange
formatRange = .Rows.Count / splitRow
For i = 1 To .Rows.Count Step formatRange
.Cells(i, 1).Resize(formatRange, 1).Interior.ColorIndex = i / formatRange + 3
Next i
End With
Application.ScreenUpdating = True
End Sub
I have written the below code to isolate unique values when comparing range 1 and range 2. I want it to also evaluate the cell in the same row in range 3 to make sure it is not equal to zero. Any tips on how to accomplish that?
Sub CompareRanges()
Dim WorkRng1 As Range, WorkRng2 As Range, WorkRng3 As Range, Rng1 As Range, Rng2 As Range, Rng3 As Range
xTitleId = "Compare Ranges"
Set WorkRng1 = Application.InputBox("Please Select Task ID Range in Invoice Review File", xTitleId, Type:=8)
Set WorkRng2 = Application.InputBox("Please Select Task ID Range in Budget Grid", xTitleId, Type:=8)
Set WorkRng3 = Application.InputBox("Please Select", xTitleId, Type:=8)
For Each Rng1 In WorkRng1
For Each Rng2 In WorkRng2
If Rng1.Value = Rng2.Value Then
Rng2.Interior.Color = VBA.RGB(254, 255, 255)
Exit For
End If
Next
Next
For Each Rng2 In WorkRng2
For Each Rng3 In WorkRng3
If Rng2.Value > 0 And Rng3.Value <> 0 And Rng2.Interior.Color <> VBA.RGB(254, 255, 255) Then
Rng2.Interior.Color = VBA.RGB(255, 0, 0)
Exit For
End If
Next
Next
End Sub
As Portland Runner answered:
Try: And Cells(Rng2.Row, Rng3.Column) <> 0 instead of And
Rng3.Value <> 0
I have a loop in VBA that loops through about 3000+ records and hides the ones that don't fit the criteria. It works just fine but it runs SUPER slow. Is there a faster or more efficient way to filter based on the following criteria? Any help would be greatly appreciated.
Dim i As Long, rng1 As Range, rng2 As Range, rng3 As Range, rng4 As Range, rng5 As Range, j As Long, sheetName As String, rng6 As Range, rng7 As Range, rng8 As Range, rng9 As Range
Set rng1 = FindHeader("Client Exclusion List", Sheet8.Name)
Set rng2 = FindHeader("CLIENT NAME", Sheet5.Name)
Set rng3 = FindHeader("MARKET SEGMENT", Sheet5.Name)
Set rng4 = FindHeader("ARCHIVED", Sheet5.Name)
Set rng5 = FindHeader("FORMULARY NAME", Sheet5.Name)
Set rng6 = FindHeader("WEBSITE", Sheet5.Name)
Set rng7 = FindHeader("PDF", Sheet5.Name)
Set rng8 = FindHeader("HPMS EXPORTED", Sheet5.Name)
Set rng9 = FindHeader("SERFF EXPORTED", Sheet5.Name)
For i = 1 To rng2.Rows.Count
'Checks to see if the Client Name is in the Excluded list
For j = 1 To rng1.Rows.Count
If rng2.Cells(i, 1).Value = rng1.Cells(j, 1).Value Then
rng2.Cells(i, 1).EntireRow.Hidden = True
End If
Next j
'Checks For all CMS records and hides the ones that are not from current year
If Left(rng3.Cells(i, 1).Value, 8) = "CMS Part" Then
If rng3.Cells(i, 1).Value <> "CMS Part D (CY " & Year(Date) & ")" Then
rng3.Cells(i, 1).EntireRow.Hidden = True
End If
End If
'Checks if record is archived
If rng4.Cells(i, 1).Value = "Yes" Then
rng4.Cells(i, 1).EntireRow.Hidden = True
End If
'Checks if record contains "Test" or "Demo" in the Name
If InStr(1, CStr(rng5.Cells(i, 1).Value), "test") > 0 Or InStr(1, CStr(rng5.Cells(i, 1).Value), "Test") > 0 Or InStr(1, CStr(rng5.Cells(i, 1).Value), "demo") > 0 Or InStr(1, CStr(rng5.Cells(i, 1).Value), "Demo") > 0 Or InStr(1, CStr(rng5.Cells(i, 1).Value), "TEST") > 0 Or InStr(1, CStr(rng5.Cells(i, 1).Value), "DO NOT USE") > 0 Then
rng5.Cells(i, 1).EntireRow.Hidden = True
End If
Next i
Here's an example that should be faster. It uses array, autofilter and doesn't process all the other ranges for each row of rng2:
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim rng4 As Range
Dim rng5 As Range
Dim rng6 As Range
Dim rng7 As Range
Dim rng8 As Range
Dim rng9 As Range
Dim i As Long
Dim j As Long
Dim sheetName As String
Dim vData1
Set rng1 = FindHeader("Client Exclusion List", Sheet8.Name)
Set rng2 = FindHeader("CLIENT NAME", Sheet5.Name)
Set rng3 = FindHeader("MARKET SEGMENT", Sheet5.Name)
Set rng4 = FindHeader("ARCHIVED", Sheet5.Name)
Set rng5 = FindHeader("FORMULARY NAME", Sheet5.Name)
Set rng6 = FindHeader("WEBSITE", Sheet5.Name)
Set rng7 = FindHeader("PDF", Sheet5.Name)
Set rng8 = FindHeader("HPMS EXPORTED", Sheet5.Name)
Set rng9 = FindHeader("SERFF EXPORTED", Sheet5.Name)
Application.ScreenUpdating = False
vData1 = rng1.Value
For i = 1 To rng2.Rows.Count
'Checks to see if the Client Name is in the Excluded list
For j = LBound(vdata1, 1) To UBound(vdata1, 1)
If rng2.Cells(i, 1).Value = vdata1(j, 1) Then
rng2.Cells(i, 1).EntireRow.Hidden = True
Exit For
End If
Next j
Next i
'Checks For all CMS records and hides the ones that are not from current year
rng3.AutoFilter 1, "<>CMS Part*", xlOr, "CMS Part D (CY " & Year(Date) & ")"
'Checks if record is archived
rng4.AutoFilter 1, "<>Yes"
'Checks if record contains "Test" or "Demo" in the Name
rng5.AutoFilter 1, "<>*test*", xlAnd, "<>*demo*"
Application.ScreenUpdating = True
One small change that should help is adding
Application.ScreenUpdating = False
at the beginning and
Application.ScreenUpdating = True
at the end
The screen updating time can be much more substantial than the logic.
Edit as an alternative to the array loop. Creates a dictionary filled with the excluded items as keys before the big loop. A set would be better here since you have a useless item to go with each key but I don't think VBA has those.
Instead of the loop through the range or an array you just check for the existence of the key in the dictionary.
'before loop
Dim excludedList As Object
Set excludedList = CreateObject("Scripting.Dictionary")
For i = 1 To rng1.Rows.Count
excludedList.Add rng1.Cells(i, 1).value, 1
Next i
'****************************************
'in loop
If excludedList.exists(rng2.Cells(i, 1).Value) Then
rng2.Cells(i, 1).EntireRow.Hidden = True
End If