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
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 am trying to transform my data in columns to a single column.
Example data:
A B C
1 2 3
D E F
I want it in a single column:
A
1
D
B
2
E
C
3
F
I am using this code I found on the web.
Sub ConvertRangeToColumn()
Dim Range1 As Range, Range2 As Range, Rng As Range
Dim rowIndex As Integer
xTitleId = "KutoolsforExcel"
Set Range1 = Application.Selection
Set Range1 = Application.InputBox("Source Ranges:", xTitleId, Range1.Address, Type:=8)
Set Range2 = Application.InputBox("Convert to (single cell):", xTitleId, Type:=8)
rowIndex = 0
Application.ScreenUpdating = False
For Each Rng In Range1.Rows
Rng.Copy
Range2.Offset(rowIndex, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=True
rowIndex = rowIndex + Rng.Columns.Count
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
This turns my data to:
A
B
C
1
2
3
D
E
F
As it seeks the data horizontally.
Try,
dim c as long, r as long
for c= 2 to cells(1, columns.count).end(xltoleft).column
for r=1 to cells(rows.count, c).end(xlup).row
cells(rows.count, "A").end(xlup).offset(1, 0) = cells(r,c)
next r
columns(c).clear
next c
I only made 3 adjustments here to fit the code you found to work for your situation.
Sub ConvertRangeToColumn()
Dim Range1 As Range, Range2 As Range, Rng As Range
Dim rowIndex As Integer
Set Range1 = Application.Selection
Set Range1 = Application.InputBox("Source Ranges:", xTitleId, Range1.Address, Type:=8)
Set Range2 = Application.InputBox("Convert to (single cell):", xTitleId, Type:=8)
rowIndex = 0
Application.ScreenUpdating = False
For Each Rng In Range1.Columns
Rng.Copy
Range2.Offset(rowIndex, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=False
rowIndex = rowIndex + Rng.Rows.Count
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Using mostly your code:
Sub ConvertRangeToColumn()
Dim xTitleId$
Dim Range1 As Range, Range2 As Range, Rng As Range
Dim rowIndex As Integer
xTitleId = "KutoolsforExcel"
Set Range1 = Application.Selection
Set Range1 = Application.InputBox("Source Ranges:", xTitleId, Range1.Address, Type:=8)
Set Range2 = Application.InputBox("Convert to (single cell):", xTitleId, Type:=8)
rowIndex = 0
Application.ScreenUpdating = False
For Each Rng In Range1.Columns
Rng.Copy
Range2.Offset(rowIndex, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=False
rowIndex = rowIndex + Rng.Rows.Count
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
you could avoid paste special and consequent clipboard clearance by handling range values only:
Sub ConvertRangeToColumn()
Dim Range2 As Range
Dim xTitleId As String
Dim iCol As Long
xTitleId = "KutoolsforExcel"
Set Range2 = Application.InputBox("Convert to (single cell):", xTitleId, Type:=8) 'get cell where to start writing down
With Application.InputBox("Source Ranges:", xTitleId, Selection.Address, Type:=8) ' get and reference the 2D range to be "transformed" into 1 column
For iCol = 1 To .Columns.Count ' loop through referenced range columns
Range2.Offset((iCol - 1) * .Rows.Count, 0).Resize(.Rows.Count).Value = .Columns(iCol).Value ' write referenced range current column values into 'Range2 proper row offset'
Next
End With
End Sub
You could use Power Query, available in Windows Excel 2010+ and Office 365
Given how you want it to be ordered
Transpose
Unpivot after selecting all of the columns
Delete the Attribute column
Note: when creating the table, since there are no headers, be sure to deselect the box that says "my table has headers"
M Code
let
Source = Excel.CurrentWorkbook(){[Name="Table7"]}[Content],
#"Changed Type" = Table.TransformColumnTypes(Source,{{"Column1", type any}, {"Column2", type any}, {"Column3", type any}}),
#"Transposed Table" = Table.Transpose(#"Changed Type"),
#"Unpivoted Columns" = Table.UnpivotOtherColumns(#"Transposed Table", {}, "Attribute", "Value"),
#"Removed Columns" = Table.RemoveColumns(#"Unpivoted Columns",{"Attribute"}),
#"Changed Type1" = Table.TransformColumnTypes(#"Removed Columns",{{"Value", type text}})
in
#"Changed Type1"
If you dispose of the new dynamic Excel functions ArrayToText and Transpose (Excel/MS365) you might use a simple udf:
Public Function Split2Col(rng As Range)
Dim tmp: tmp = Evaluate("ArrayToText(Transpose(" & rng.Address(False, False, External:=True) & "))")
Split2Col = Application.Transpose(Split(tmp, ", "))
End Function
Sub Duplicate()
Dim WorkRng1 As Range, WorkRng2 As Range, Rng1 As Range, Rng2 As Range
Set ws = ThisWorkbook.Sheets("Sheet3")
xTitleId = "KutoolsforExcel"
Set WorkRng1 = Application.InputBox("Range A:", xTitleId, "", Type:=8)
Set WorkRng2 = Application.InputBox("Range B:", xTitleId, Type:=8)
For Each Rng1 In WorkRng1
rng1Value = Rng1.Value
For Each Rng2 In WorkRng2
If rng1Value = Rng2.Value Then
MsgBox rng1Value
Rng1.Interior.Color = VBA.RGB(255, 0, 0)
Else
ws.Cells("A2") = rng1Value
Exit For
End If
Next
Next
End Sub
I'm more than new at this, and I'm having trouble sorting out For...Next loops.
I want to track to two text variables in two columns, so that when both variables are found in a row text is added to that row in a different column.
This is what I have so far:
Sub AB()
Dim Rng1 As Range
Dim Rng2 As Range
Set Rng1 = Range("B1:B100")
Set Rng2 = Range("A1:A100")
For Each cel In Rng1
If InStr(1, cel.Value, "A") > 0 Then
For Each cel In Rng2
If InStr(1, cel.Value, "B") > 0 Then
cel.Offset(0, 5).Value = "AB"
End If
Next
End If
Next cel
End Sub
You might even be able to just do this?
Sub AB()
With ActiveSheet
For I = 1 To 100
If InStr(1, .Cells(I, 2), "A") > 0 And InStr(1, .Cells(I, 1), "B") > 0 Then
.Cells(I, 6).Value = "AB" 'i think offset 5 is column F?
End If
Next
End With
End Sub
Appreciate you have an answer now, but here's a different method using Find. Always good to know several ways to do something.
Sub AB()
Dim rng As Range
Dim itemaddress As String
With Columns(1)
Set rng = .Find("A", searchorder:=xlByRows, lookat:=xlWhole)
If Not rng Is Nothing Then
itemaddress = rng.Address
Do
If rng.Offset(0, 1) = "B" Then
rng.Offset(0, 2).Value = "AB"
End If
Set rng = .FindNext(rng)
Loop While Not rng Is Nothing And itemaddress <> rng.Address
End If
End With
End Sub
You're using `cel' to step through each loop - the inner loop will get confused.
Along the vein of #findwindow answer (appeared as I was typing this). Loop just once and when a match is found check the cell next to it.
Sub AB()
Dim Rng1 As Range
Dim Rng2 As Range
Dim cel1 As Range
'Be specific about which sheet your ranges are on.
With ThisWorkbook.Worksheets("Sheet1")
Set Rng1 = .Range("B1:B100")
Set Rng2 = .Range("A1:A100")
End With
For Each cel1 In Rng1
'Check each value in column B.
If InStr(1, cel1.Value, "A") > 0 Then
'If a match is found, check the value next to it.
If InStr(1, cel1.Offset(, -1), "B") > 0 Then
cel1.Offset(, 4).Value = "AB"
End If
End If
Next cel1
End Sub
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