VBA: Keep first and last rows of duplicate column values of an Excel sheet - excel

I have an Excel worksheet with 20K rows like this:
header1
header2
1
P
2
P
3
P
4
Q
5
R
6
R
7
R
8
R
9
S
10
S
I want a VBA code to delete the rows containing duplicates, but keep the first and last row of the duplicates. The result should be like this:
header1
header2
1
P
3
P
4
Q
5
R
8
R
9
S
10
S
I have modified the following code found here to do just that, but every time I have to manually select the range containing the duplicates in column header2.
Sub Delete_Dups_Keep_Last_v2()
Dim SelRng As Range
Dim Cell_in_Rng As Range
Dim RngToDelete As Range
Dim SelLastRow As Long
Application.DisplayAlerts = False
Set SelRng = Application.InputBox("Select cells", Type:=8)
On Error GoTo 0
Application.DisplayAlerts = True
SelLastRow = SelRng.Rows.Count + SelRng.Row - 1
For Each Cell_in_Rng In SelRng
If Cell_in_Rng.Row < SelLastRow Then
If Cell_in_Rng.Row > SelRng.Row Then
If Not Cell_in_Rng.Offset(1, 0).Resize(SelLastRow - Cell_in_Rng.Row).Find(What:=Cell_in_Rng.Value, Lookat:=xlWhole) Is Nothing Then
'this value exists again in the range
If RngToDelete Is Nothing Then
Set RngToDelete = Cell_in_Rng
Else
Set RngToDelete = Application.Union(RngToDelete, Cell_in_Rng)
End If
End If
End If
End If
Next Cell_in_Rng
If Not RngToDelete Is Nothing Then RngToDelete.EntireRow.Delete
End Sub
Another code found here by user A.S.H. automates the manual selection and speed by using Dictionary, but fails to produce the wanted result.
Sub keepFirstAndLast()
Dim toDelete As Range: Set toDelete = Sheet1.Rows(999999) '(to not start with a null range)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim a As Range
For Each a In Sheet1.Range("B2", Sheet1.Range("B999999").End(xlUp))
If Not dict.Exists(a.Value2) Then
dict(a.Value2) = 0 ' first appearence, dont save the row
Else
' if last observed occurrence was a duplicate, add it to deleted range
If dict(a.Value2) > 0 Then Set toDelete = Union(toDelete, Sheet1.Rows(dict(a.Value2)))
dict(a.Value2) = a.row ' not first appearence, save the row for eventual deletion
End If
Next
toDelete.Delete
End Sub

Simple solution:
Sub KeepFirstLast()
Application.ScreenUpdating = False
Dim lastRow As Long
lastRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
Dim i As Long
Dim x As Long
Dim currentValue As String
For i = lastRow To 2 Step -1
If i = 2 Then
Application.ScreenUpdating = True
Exit For
End If
currentValue = Sheets(1).Cells(i, 2).Value
x = i - 1
Do While Sheets(1).Cells(x, 2).Value = currentValue And Sheets(1).Cells(x - 1, 2).Value = currentValue
Sheets(1).Rows(x).Delete
x = x - 1
Loop
i = x + 1
Next i
Application.ScreenUpdating = True
End Sub

You may benefit from SpecialCells to select those rows based on formula:
Sub test()
Dim LR As Long 'last row
Dim LC As Long 'last column
Dim SR As Long 'starting row
Dim rng As Range
Set rng = Range("A1") 'change this to TOP LEFT CELL OF YOUR DATA
SR = rng.Row
LR = rng.CurrentRegion.Cells(rng.CurrentRegion.Rows.Count, 1).Row
LC = Cells(1, Columns.Count).End(xlToLeft).Column 'last column used
'we add new column with formula to delete
With Range(Cells(SR + 1, LC + 1), Cells(LR, LC + 1))
.FormulaR1C1 = "=IF(OR(RC[-1]<>R[-1]C[-1],RC[-1]<>R[1]C[-1]),""x"",0)"
.SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete
End With
'clear formula
LR = rng.CurrentRegion.Cells(rng.CurrentRegion.Rows.Count, 1).Row
Range(Cells(SR + 1, LC + 1), Cells(LR, LC + 1)).Clear
Set rng = Nothing
End Sub
[![enter image description here][1]][1]
The tricky part is here:
.FormulaR1C1 = "=IF(OR(RC[-1]<>R[-1]C[-1],RC[-1]<>R[1]C[-1]),""x"",0)"
.SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete
First line will create and IF(OR) formula to check if the row must be deleted or not. It will return x if not, else 0
Second line will delete entire rows only if it contains a number (zero)
[1]: https://i.stack.imgur.com/UlhtI.gif

This can also be accomplished using Power Query, available in Windows Excel 2010+ and Excel 365 (Windows or Mac)
To use Power Query
Select some cell in your Data Table
Data => Get&Transform => from Table/Range or from within sheet
When the PQ Editor opens: Home => Advanced Editor
Make note of the Table Name in Line 2
Paste the M Code below in place of what you see
Change the Table name in line 2 back to what was generated originally.
Read the comments and explore the Applied Steps to understand the algorithm
M Code
let
//change next line to your actual table name in your worksheet
Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
#"Changed Type" = Table.TransformColumnTypes(Source,{{"header1", Int64.Type}, {"header2", type text}}),
//Group by header2
// then return the first and last table rows if there is more than a single row
#"Grouped Rows" = Table.Group(#"Changed Type", {"header2"}, {
{"header1", each if Table.RowCount(_) = 1 then _
else Table.FromRecords({Table.First(_),Table.Last(_)}),
type table[header1=Int64.Type, header2=text]}
}),
//expand the subtables and set the column order
#"Expanded header1" = Table.ExpandTableColumn(#"Grouped Rows", "header1", {"header1"}),
#"Reordered Columns" = Table.ReorderColumns(#"Expanded header1",{"header1", "header2"})
in
#"Reordered Columns"

Keep First and Last In Sorted Range
Option Explicit
Sub DeleteNotFirstNorLast()
Const ProcName As String = "DeleteNotFirstNorLast"
Dim RowsDeleted As Boolean ' to inform
On Error GoTo ClearError ' enable error trapping
' Constants (adjust!)
Const FirstCellAddress As String = "A1"
Const CriteriaColumnIndex As Long = 2
Const Criteria As String = "#$%"
' Reference the worksheet.
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Application.ScreenUpdating = False
' Turn off AutoFilter.
If ws.AutoFilterMode Then ws.AutoFilterMode = False
' Reference the table range.
Dim trg As Range: Set trg = RefCurrentRegion(ws.Range(FirstCellAddress))
' Write an ascending integer sequence adjacent to the right
' of the table range.
AppendColumnOfAscendingIntegers trg
' Include this helper column to the table range.
Set trg = trg.Resize(, trg.Columns.Count + 1)
' Reference the criteria column range.
Dim crg As Range: Set crg = trg.Columns(CriteriaColumnIndex)
' It is assumed that the criteria column is already sorted favorably.
' If not, you could do something like the following:
' Sort the table range by the criteria column ascending.
'trg.Sort crg, xlAscending, , , , , , xlYes
' Write the data rows (no headers) count to a variable.
Dim drCount As Long: drCount = trg.Rows.Count - 1
' Reference the criteria column data range (headers excluded).
Dim cdrg As Range: Set cdrg = crg.Resize(drCount).Offset(1)
' Write the values from the criteria column data range to an array.
Dim cData As Variant: cData = GetRange(cdrg)
' Replace the unwanted values in the array with the criteria.
KeepFirstAndLastInColumn cData
' Write the (modified) values from the array back to the range.
cdrg.Value = cData
' Reference the table data range (no headers).
Dim tdrg As Range: Set tdrg = trg.Resize(drCount).Offset(1)
' Filter the table range in the criteria column by the criteria.
trg.AutoFilter CriteriaColumnIndex, Criteria
' Attempt to reference the table data visible (filtered) range.
Dim tdvrg As Range
On Error Resume Next ' defer error trapping
Set tdvrg = tdrg.SpecialCells(xlCellTypeVisible)
On Error GoTo ClearError ' re-enable error trapping
' Remove the filter.
ws.AutoFilterMode = False
' Attempt to delete the table data visible range.
If Not tdvrg Is Nothing Then
tdvrg.Delete xlShiftUp
RowsDeleted = True
End If
' Reference the helper column.
Dim hrg As Range: Set hrg = trg.Columns(trg.Columns.Count)
' Sort the table range by the helper column ascending.
trg.Sort hrg, xlAscending, , , , , , xlYes
' Clear the helper column.
hrg.Clear
SafeExit:
Application.ScreenUpdating = True ' to see any changes while reading message
' Inform.
If RowsDeleted Then
MsgBox "Rows deleted.", vbInformation, ProcName
Else
MsgBox "Nothing deleted.", vbExclamation, ProcName
End If
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume SafeExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns a reference to the range starting with the first cell
' of a range and ending with the last cell of the first cell's
' Current Region.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCurrentRegion( _
ByVal FirstCell As Range) _
As Range
Const ProcName As String = "RefCurrentRegion"
On Error GoTo ClearError
If FirstCell Is Nothing Then Exit Function
With FirstCell.Cells(1).CurrentRegion
Set RefCurrentRegion = FirstCell.Resize(.Row + .Rows.Count _
- FirstCell.Row, .Column + .Columns.Count - FirstCell.Column)
End With
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Writes an ascending integer sequence adjacent to the right
' of a range.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub AppendColumnOfAscendingIntegers( _
ByVal trg As Range, _
Optional ByVal FirstInteger As Long = 1)
Const ProcName As String = "AppendColumnOfAscendingIntegers"
On Error GoTo ClearError
With trg
With .Resize(, 1).Offset(, .Columns.Count)
.Value = .Worksheet.Evaluate("ROW(" & CStr(FirstInteger) & ":" _
& CStr(FirstInteger + .Rows.Count - 1) & ")")
End With
End With
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a range ('trg') in a 2D one-based array.
' Remarks: If ˙rg` refers to a multi-range, only its first area
' is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
ByVal trg As Range) _
As Variant
Const ProcName As String = "GetRange"
On Error GoTo ClearError
If trg.Rows.Count + trg.Columns.Count = 2 Then ' one cell
Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = trg.Value
GetRange = Data
Else ' multiple cells
GetRange = trg.Value
End If
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: In the first column of a 2D one-based array of sorted values,
' keeps the first and last occurrence of each value and replaces
' the remaining occurrences with a string.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub KeepFirstAndLastInColumn( _
ByRef cData As Variant, _
Optional ByVal Criteria As String = "#$%")
Const ProcName As String = "KeepFirstAndLastInColumn"
On Error GoTo ClearError
Dim OldString As String: OldString = CStr(cData(1, 1))
Dim r As Long
Dim cr As Long
Dim FirstRow As Long
Dim NewString As String
For r = 2 To UBound(cData, 1)
NewString = CStr(cData(r, 1))
If NewString = OldString Then
If FirstRow = 0 Then
FirstRow = r
End If
Else
If FirstRow > 0 Then
For cr = FirstRow To r - 2
cData(cr, 1) = Criteria
Next cr
FirstRow = 0
End If
OldString = NewString
End If
Next r
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub

Related

How to correct code so that it runs or inserts formula in column to left of Range for cells that = "Metered"

I have a worksheet where column C has a formula that looks up value if column D = "Metered".
Users, who are mostly farm workers, have the ability to overwrite it (or possibly delete it using the Make Correction button). Unless column D = "Metered", I don't care if column C is overwritten because data validation makes sure entry is OK. Users are supposed to Tab past column C unless load is "Metered". As a failsafe, I duplicated the "Metered" lookup formula elsewhere and the results are in column S. I don't get any errors on code below, but it doesn't do anything -- previous versions would do things but not the right things. Clearly, I cannot solve this on my own and very much appreciate any help you can provide. I want to run the failsafe once a day when the workbook is opened (running on laptops and speed is important).
Private Sub Workbook_Open()
Application.OnTime TimeValue("02:57:00"), "SaveBeforeDailyRestart"
Application.MoveAfterReturnDirection = xlToRight
Call MeteredLookupRefreshFormula
End Sub
Sub MeteredLookupRefreshFormula()
Sheet1.Unprotect Password:="Cami8"
Dim bng As Range
Set bng = Range("D8:D10009")
For Each cell In bng
If Value = "Metered" Then
bng.Offset(0, -1).Select
Selection.Value = "S & ActiveCell.Row)"
Else
End If
Next
Sheet1.Protect Password:="Cami8"
End Sub
Loop Through Cells
A Quick Fix (Slow)
To not be dependent on the offset you could additionally do:
cell.EntireRow.Columns("C").Value = cell.EntireRow.Columns("S").Value
Sub MeteredLookupRefreshFormulaQuickFix()
With Sheet1
.Unprotect Password:="Cami8"
With .Range("D8:D10009")
Dim cell As Range
For Each cell In .Cells
If StrComp(CStr(cell.Value), "Metered", vbTextCompare) = 0 Then
cell.Offset(0, -1).Value = cell.EntireRow.Columns("S").Value
End If
Next cell
End With
.Protect Password:="Cami8"
End With
End Sub
An Improvement (Fast)
If you have many cells containing formulas evaluating to an empty string ="" at the bottom of column D, replace xlFormulas with xlValues for these cells not to be processed and speed up even more.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Refreshes...
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Calls: RefColumn,GetRange.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub MeteredLookupRefreshFormula()
Const cfcAddress As String = "D8"
Const dCol As String = "C"
Const sCol As String = "S"
Const Criteria As String = "Metered"
Const pw As String = "Cami8"
Sheet1.Unprotect Password:=pw
Dim crg As Range: Set crg = RefColumn(Sheet1.Range(cfcAddress))
If crg Is Nothing Then Exit Sub ' no data
Dim cData As Variant: cData = GetRange(crg)
Dim drg As Range: Set drg = crg.EntireRow.Columns(dCol)
Dim dData As Variant: dData = GetRange(drg)
Dim sData As Variant: sData = GetRange(crg.EntireRow.Columns(sCol))
Dim r As Long
For r = 1 To UBound(cData, 1)
If StrComp(CStr(cData(r, 1)), Criteria, vbTextCompare) = 0 Then
dData(r, 1) = sData(r, 1)
End If
Next r
drg.Value = dData
Sheet1.Protect Password:=pw
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the one-column range ('crg') whose first
' cell is defined by the first cell of the range ('FirstCell')
' and whose last cell is the bottom-most non-empty cell
' of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
ByVal FirstCell As Range) _
As Range
Const ProcName As String = "RefColumn"
On Error GoTo ClearError
With FirstCell.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
Set RefColumn = .Resize(lCell.Row - .Row + 1)
End With
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a range ('rg') in a 2D one-based array.
' Remarks: If ˙rg` refers to a multi-range, only its first area
' is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
ByVal rg As Range) _
As Variant
Const ProcName As String = "GetRange"
On Error GoTo ClearError
If rg.Rows.Count + rg.Columns.Count = 2 Then ' one cell
Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
GetRange = Data
Else ' multiple cells
GetRange = rg.Value
End If
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
It appears as though the contents of your FOR loop is all screwed up. This is untested but change this ...
For Each cell In bng
If Value = "Metered" Then
bng.Offset(0, -1).Select
Selection.Value = "S & ActiveCell.Row)"
Else
End If
Next
... to this ...
For Each cell In bng
If cell.Value = "Metered" Then
cell.Offset(0, -1).Value = cell.Worksheet.Range("S" & cell.Row).Value
End If
Next
... and it should help.

Optimizing VBA code running time finding username of a range in another worksheet and return value if found

Good day all ,
I am trying to find each cell value in column A of worksheet "OFSHC" in worksheet "User Assessments" and if value found then return "true" in column V of the corresponding cell in worksheet "OFSHC" else return "false.
I have the code below , however; I am working with +90000 rows in worksheet "OFSHC" and +900000 rows in sheet "User Assessments" , which makes the code to run over 6 hours. any idea on optimizing the code to run for a shorter period of time?
Code:
Sub findUsername_OFSHC_User_Assessments()
Worksheets("OFSHC").Activate
Dim FindString As String
Dim Rng As Range
For Each Cell In Range("A2:A35000")
FindString = Cell.Value
If Trim(FindString) <> "" Then
'The 2nd worksheet is assumed to be User Assessments. Change this if it is not the case
With Sheets("User Assessments").Range("D1:D900000")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
Application.GoTo Rng, True
'In Sheet 2: This line shifts 5 cells to the right and gets the country value
'Found = ActiveCell.Offset(0, 5).Value
'In Sheet 1: Found value is pasted into the cell 3 cells to the right of the cell containing the Workday usernme
Cell.Offset(0, 22).Value = "True"
Else
Cell.Offset(0, 22).Value = "False"
End If
End With
End If
Next
End Sub
Lookup Data Using Application.Match
Adjust the values in the constants section.
First, test it on a smaller dataset since it'll still take some time (not tested on a large dataset).
Only run the first procedure which will call the remaining two when necessary.
Option Explicit
Sub findUsername_OFSHC_User_Assessments()
' Constants
Const sName As String = "User Assessments"
Const sFirst As String = "D2"
Const dName As String = "OFSHC"
Const lFirst As String = "A2"
Const dFirst As String = "V2"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source
Dim sData As Variant: sData = getColumn(wb.Worksheets(sName).Range(sFirst))
If IsEmpty(sData) Then Exit Sub
' Lookup
Dim ldData As Variant: ldData = getColumn(wb.Worksheets(dName).Range(lFirst))
If IsEmpty(ldData) Then Exit Sub
Dim rCount As Long: rCount = UBound(ldData, 1)
' Destination
Dim r As Long
For r = 1 To rCount
If IsNumeric(Application.Match(ldData(r, 1), sData, 0)) Then
ldData(r, 1) = True ' "'True"
Else
ldData(r, 1) = False ' "'False"
End If
Next r
' Write
writeDataSimple wb.Worksheets(dName).Range(dFirst), ldData, True
End Sub
Function getColumn( _
FirstCellRange As Range) _
As Variant
Const ProcName As String = "getColumn"
On Error GoTo clearError
If Not FirstCellRange Is Nothing Then
With FirstCellRange.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If Not lCell Is Nothing Then
Dim rCount As Long: rCount = lCell.Row - .Row + 1
Dim Data As Variant
If rCount = 1 Then
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = .Value
Else
Data = .Resize(rCount).Value
End If
getColumn = Data
End If
End With
End If
ProcExit:
Exit Function
clearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
Sub writeDataSimple( _
ByVal FirstCellRange As Range, _
ByVal Data As Variant, _
Optional ByVal doClearContents As Boolean = True)
Const ProcName As String = "writeDataSimple"
On Error GoTo clearError
If Not FirstCellRange Is Nothing Then
If Not IsEmpty(Data) Then
Dim rCount As Long: rCount = UBound(Data, 1)
With FirstCellRange.Cells(1).Resize(, UBound(Data, 2))
.Resize(rCount).Value = Data
If doClearContents Then
.Resize(.Worksheet.Rows.Count - .Row - rCount + 1) _
.Offset(rCount).ClearContents
End If
End With
End If
End If
ProcExit:
Exit Sub
clearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Sub
Here's a dictionary-based example using the same range sizes (35k lookup values against a 900k list).
In my testing it ran in < 10sec.
Notes:
Loading up a dictionary gets progressively slower as the number of items get larger, so here we're keeping the size below 100k by using a bunch of dictionaries, which collectively all load faster (~8-9sec) than loading all the values into a single dictionary (>50sec). We lose a bit of speed on the lookups, but still much faster.
This is based on all of your ColA values being unique - if they're not then whether or not that matters would depend on your exact use case. In this specific instance you're just looking for any match, so it's OK, but if for example you wanted to find all matches from a non-unique list you'd need to re-work the approach.
Sub Tester()
Dim dict, arr, t, r As Long, arr2, arrRes, i As Long
Dim colDicts As New Collection, arrK, res As Boolean
t = Timer
Set dict = CreateObject("scripting.dictionary")
arr = Range("A2:A900000").Value 'the lookup range
For r = 1 To UBound(arr, 1)
If r Mod 100000 = 1 Then
Set dict = CreateObject("scripting.dictionary")
colDicts.Add dict
End If
dict(arr(r, 1)) = True
Next r
Debug.Print "Loaded dictionaries", Timer - t
arr2 = Range("C2:C35000").Value 'values to be found
ReDim arrRes(1 To UBound(arr2, 1), 1 To 1) 'size array for results
For r = 1 To UBound(arr2, 1)
res = False
For Each dict In colDicts 'check each dictionary
If dict.exists(arr2(r, 1)) Then
res = True
Exit For 'done checking
End If
Next dict
arrRes(r, 1) = res 'assign true/false
Next r
Range("D2").Resize(UBound(arr2, 1), 1).Value = arrRes
Debug.Print "Done", Timer - t '< 10sec
End Sub

VBA filtering list using another list

I'm trying to filter the ID in a table, using IDs from another list. However, when I try to do so the macro only filters the first value in the list.
Table Format
Code:
Sub Test()
Dim wb As Workbook
Set wb = ThisWorkbook
ActiveSheet.AutoFilterMode = False
Workbooks.Open "C:\List.xlsx"
Criteria = Worksheets("DataArray").Range("A3:A103")
wb.Activate
ActiveSheet.Range("$A$8:$BE$5000").AutoFilter Field:=3, Criteria1:=Criteria, Operator:=xlFilterValues
End Sub
The "List" is in another workbook so I need the macro to open it first.
When I try changing the Range to A4:A103 the filter will just use the A4 (first value in the range).
Try the next way, please:
Dim Crit As Variant
Set Crit = Worksheets("DataArray").Range("A3:A103").Value
ActiveSheet.Range("$A$8:$BE$5000").AutoFilter Field:=3, Criteria1:=Application.Transpose(Crit), Operator:=xlFilterValues
The column list must be transposed on a row. Otherwise, only its first element will be used.
You can do all this by selecting the ranges (directly in the Excel interface). The following code is reusable:
Option Explicit
Public Sub FilterBySelection()
Dim rngFirst As Range
Dim rngSecond As Range
'
'Get Ranges from User Selection
Set rngFirst = GetRangeBySelection("Select range to filter!" _
& vbNewLine & "Please select a single continuous range!" _
& vbNewLine & vbNewLine & "Note that by selecting a single cell, your" _
& " selection will default to the current region for that cell!" _
, "Select Range")
If rngFirst Is Nothing Then Exit Sub
'
Set rngSecond = GetRangeBySelection("Select range containing filtering values!" _
& vbNewLine & "Please select a single continuous range!" _
& vbNewLine & vbNewLine & "Note that by selecting a single cell, your" _
& " selection will default to the current region for that cell!" _
, "Select Range")
If rngSecond Is Nothing Then Exit Sub
'
'Filter first range using values from the second range
Dim arrValues() As Variant: arrValues = rngSecond.Value2
Dim arrCriteria() As Variant
Dim i As Long
Dim v As Variant
'
'Criteria values must be a 1-dimension array
ReDim arrCriteria(0 To rngSecond.Count - 1)
i = 0
For Each v In arrValues
arrCriteria(i) = CStr(v) 'Criteria must be string data type
i = i + 1
Next v
'
'Filter
On Error Resume Next
If rngFirst.ListObject Is Nothing Then
rngFirst.AutoFilter
rngFirst.AutoFilter Field:=1, Criteria1:=arrCriteria, Operator:=xlFilterValues
Else
With rngFirst.ListObject.Range
.AutoFilter Field:=rngFirst.Column - .Column + 1 _
, Criteria1:=arrCriteria, Operator:=xlFilterValues
End With
End If
On Error GoTo 0
End Sub
Public Function GetRangeBySelection(ByVal prompt_ As String, ByVal title_ As String) As Range
Dim rng As Range
'
Do While rng Is Nothing
On Error Resume Next
Set rng = Application.InputBox(Prompt:=prompt_, Title:=title_, Type:=8)
If rng.Cells.Count = 1 Then Set rng = rng.CurrentRegion
On Error GoTo 0
If rng Is Nothing Then Exit Function
'
On Error GoTo ErrorHandler
If rng.Areas.Count > 1 Then
If MsgBox("Your selection contains " & rng.Areas.Count _
& " different ranges!" & vbNewLine & "Please select only 1 " _
& "range!", vbQuestion + vbRetryCancel, "Cancelled") _
<> vbRetry Then Exit Function
Set rng = Nothing
ElseIf rng.Cells.Count = 1 Then
If MsgBox("No region found from selected cell" & vbNewLine _
& "Please select more than 1 cell!", vbQuestion _
+ vbRetryCancel, "Cancelled") <> vbRetry Then Exit Function
Set rng = Nothing
ElseIf rng.Rows.Count = 1 Then
If MsgBox("Please select more than 1 row!", vbQuestion _
+ vbRetryCancel, "Cancelled") <> vbRetry Then Exit Function
Set rng = Nothing
End If
Loop
Set GetRangeBySelection = rng
Exit Function
ErrorHandler:
MsgBox "Try selecting a smaller range next time", vbInformation, "Cancelled"
End Function
Just run the FilterBySelection method
EDIT 1
Or, if you would like to have less restrictions and be able to select multiple ranges for the filtering values then use this instead:
Option Explicit
Public Sub FilterBySelection()
Dim rngFirst As Range
Dim rngSecond As Range
'
'Get Ranges from User Selection
Set rngFirst = GetRangeBySelection("Select range to filter!" _
& vbNewLine & "Please select a single continuous range!" _
, "Select Range", False)
If rngFirst Is Nothing Then Exit Sub
'
Set rngSecond = GetRangeBySelection("Select range(s) containing filtering values!" _
, "Select Range", True)
If rngSecond Is Nothing Then Exit Sub
'
'Filter first range using values from the second range
Dim rng As Range
Dim arrValues() As Variant
Dim arrCriteria() As Variant
Dim i As Long
Dim v As Variant
'
'Criteria values must be a 1-dimension array
i = 0
ReDim arrCriteria(0 To rngSecond.Count - 1)
For Each rng In rngSecond.Areas
If rng.Count = 1 Then
ReDim arrValues(0 To 0)
arrValues(0) = rng.Value2
Else
arrValues = rng.Value2
End If
For Each v In arrValues
arrCriteria(i) = CStr(v) 'Criteria must be string data type
i = i + 1
Next v
Next
'
'Filter
On Error Resume Next
If rngFirst.ListObject Is Nothing Then
rngFirst.AutoFilter
rngFirst.AutoFilter Field:=1, Criteria1:=arrCriteria, Operator:=xlFilterValues
Else
With rngFirst.ListObject.Range
.AutoFilter Field:=rngFirst.Column - .Column + 1 _
, Criteria1:=arrCriteria, Operator:=xlFilterValues
End With
End If
On Error GoTo 0
End Sub
Public Function GetRangeBySelection(ByVal prompt_ As String, ByVal title_ As String _
, allowMultiArea As Boolean) As Range
Dim rng As Range
'
Do While rng Is Nothing
On Error Resume Next
Set rng = Application.InputBox(Prompt:=prompt_, Title:=title_, Type:=8)
On Error GoTo 0
If rng Is Nothing Then Exit Function
'
On Error GoTo ErrorHandler
If rng.Areas.Count > 1 And Not allowMultiArea Then
If MsgBox("Your selection contains " & rng.Areas.Count _
& " different ranges!" & vbNewLine & "Please select only 1 " _
& "range!", vbQuestion + vbRetryCancel, "Cancelled") _
<> vbRetry Then Exit Function
Set rng = Nothing
End If
Loop
Set GetRangeBySelection = rng
Exit Function
ErrorHandler:
MsgBox "Try selecting a smaller range next time", vbInformation, "Cancelled"
End Function

Excel VBA: How do I add text to a blank cell in a specific column then loop to the next blank cell and add text?

I need a macro to add text to blank cells in Column A. The macro needs to skip cells that have text. The macro needs to stop looping at the end of the data set.
I am trying to use an If Else statement, but I think I'm on the wrong track. My current, non-working code is below. Thank you so much - I'm still new to VBA
Sub ElseIfi()
For i = 2 To 100
If Worksheets("RawPayrollDump").Cells(2, 1).Value = "" Then
Worksheets("RawPayrollDump").Cells(2, 1).Value = "Administration"
Else if(not(worksheets("RawPayrollDump").cells(2,1).value="")) then 'go to next cell
End If
Next
End Sub
To find the last row of data, use the End(xlUp) function.
Try this code. It replaces all empty cells in column A with Administration.
Sub ElseIfi()
Set ws = Worksheets("RawPayrollDump")
lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row ' last data row
For i = 2 To lastrow ' all rows until last data row
If ws.Cells(i, 1).Value = "" Then ' column A, check if blank
ws.Cells(i, 1).Value = "Administration" ' set text
End If
Next
End Sub
There is no need to loop. Please try this code.
Sub FillBlanks()
Dim Rng As Range
With Worksheets("RawPayrollDump")
Set Rng = Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp))
End With
On Error Resume Next
Set Rng = Rng.SpecialCells(xlCellTypeBlanks)
If Err Then
MsgBox "There are no blank cells" & vbCr & _
"in the specified range.", _
vbInformation, "Range " & Rng.Address(0, 0)
Else
Rng.Value = "Administration"
End If
End Sub
Replace Blanks feat. CurrentRegion
Range.CurrentRegion
Since OP asked for "... stop looping at the end of the data set. ",
I've written this CurrentRegion version.
As I understand it, the end of the data set doesn't mean that there
cannot be blank cells below the last cell containing data in column
A.
Use the 1st Sub to test the 2nd, the main Sub (replaceBlanks).
Adjust the constants including the workbook (in the 1st Sub) to fit your needs.
Criteria is declared as Variant to allow other data types not just strings.
The Code
Option Explicit
Sub testReplaceBlanks()
Const wsName As String = "RawPayrollDump"
Const FirstCellAddress As String = "A2"
Const Criteria As Variant = "Administration"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
replaceBlanks ws, FirstCellAddress, Criteria
End Sub
Sub replaceBlanks(Sheet As Worksheet, _
FirstCellAddress As String, _
Criteria As Variant)
' Define column range.
Dim ColumnRange As Range
Set ColumnRange = Intersect(Sheet.Range(FirstCellAddress).CurrentRegion, _
Sheet.Columns(Sheet.Range(FirstCellAddress) _
.Column))
' To remove the possibly included cells above the first cell:
Set ColumnRange = Sheet.Range(Range(FirstCellAddress), _
ColumnRange.Cells(ColumnRange.Cells.Count))
' Note that you can also use the addresses instead of the cell range
' objects in the previous line...
'Set ColumnRange = sheet.Range(FirstCellAddress, _
ColumnRange.Cells(ColumnRange.Cells.Count) _
.Address)
' or a mixture of them.
' Write values from column range to array.
Dim Data As Variant
If ColumnRange.Cells.Count > 1 Then
Data = ColumnRange.Value
Else
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = ColumnRange.Value
End If
' Modify array.
Dim i As Long, k As Long
For i = 1 To UBound(Data)
If IsEmpty(Data(i, 1)) Then Data(i, 1) = Criteria: k = k + 1
Next i
' Write modified array to column range.
' The following line is used when only the first cell is known...
'Sheet.Range(FirstCellAddress).Resize(UBound(Data)).Value = Data
' ...but since the range is known and is the same size as the array,
' the following will do:
ColumnRange.Value = Data
' Inform user.
If k > 0 Then GoSub Success Else GoSub Fail
Exit Sub
' Subroutines
Success:
MsgBox "Wrote '" & Criteria & "' to " & k & " previously " _
& "empty cell(s) in range '" & ColumnRange.Address & "'.", _
vbInformation, "Success"
Return
Fail:
MsgBox "No empty cells in range '" & ColumnRange.Address & "'.", _
vbExclamation, "Nothing Written"
Return
End Sub

Import variable range into Array/Collection?

Is there any way to import a range that looks like this:
I'm trying to import a range with an undetermined number of rows and columns. As the 5th row indicates, the range that I wish to import has in the first column business names and in their subsequent columns, different iterations of the same business.
I've been thinking of using arrays but I can't see it being possible as I would have varying dimensions per element (eg. 3 dimensions for canadian tire and 2 dimensions for mercedes).
I've also thought of using collections/dictionaries but I stumble at using and understanding them.
Ultimately, my intentions are to loop the iterations from this range in a column and, if any of these iterations match a cell in my column, to write in an offset cell the first iteration (business name in bold).
Now, I know, I could do a two dimensional array from a range like this, with repeated first iterations (business name):
However, it's quite cumbersome to rewrite business names.
My code below for what I was using for the two dimensional array:
Option Explicit
Sub VendorFinder()
'variable declaration
Dim msg As String
Dim ans As Integer
Dim rng As Range
Dim DescRng As Range
Dim DescCol As Range
Dim VendorCol As Range
Dim j As Long
Dim Vendor As Variant
Dim wb As Workbook
Dim sFile As String
Dim myVendor As Variant
Dim FirstRow As Range
Dim VendorRng As Range
'import vendors
sFile = "Z:\Vendor List.xlsx"
Application.ScreenUpdating = False
Set wb = Application.Workbooks.Open(sFile)
Vendor = wb.Sheets(1).Range(Cells(1, 1), Cells(Cells(Rows.Count, 2).End(xlUp).Row, 2)).Value2
wb.Close False
Application.ScreenUpdating = True
On Error GoTo BadEntry
TryAgain:
'set columns
Set DescCol = Application.InputBox("Select Description Column", "Obtain Object Range", Type:=8)
Set VendorCol = Application.InputBox("Select Vendor Column", "Obtain Object Range", Type:=8)
Set FirstRow = Application.InputBox("Select First Row with Data", "Obtain Object Range", Type:=8)
'set ranges
Set DescRng = Range(Cells(FirstRow.Row, DescCol.Column), Cells(Cells(Rows.Count, DescCol.Column).End(xlUp).Row, DescCol.Column))
Set VendorRng = Range(Cells(FirstRow.Row, VendorCol.Column), Cells(Cells(Rows.Count, DescCol.Column).End(xlUp).Row, VendorCol.Column))
myVendor = VendorRng.Value2
For Each rng In DescRng
If Cells(rng.Row, VendorCol.Column).Value = "" Then
For j = LBound(Vendor) To UBound(Vendor)
If InStr(1, rng.Value, Vendor(j, 2), vbTextCompare) > 0 Then
myVendor(rng.Row - FirstRow.Row + 1, 1) = Vendor(j, 1)
Exit For
End If
Next j
End If
Next rng
VendorRng.Resize(UBound(myVendor) - LBound(myVendor) + 1, 1) = myVendor
Exit Sub
BadEntry:
msg = "You have clicked on cancel for one of the prompts."
msg = msg & vbNewLine
msg = msg & "Do you wish to try again?"
ans = MsgBox(msg, vbRetryCancel + vbExclamation)
If ans = vbRetry Then Resume TryAgain
End Sub
Thanks a lot!
I think I might have something simpler
Dim arr As New Collection, a
Dim var() As Variant
Dim i As Long
Dim lRows As Long, lCols As Long
Dim lRowCurrent As Long
Dim lCounter As Long
'Get the active range
Set rng = ActiveSheet.UsedRange
lRows = rng.Rows.Count
lCols = rng.Columns.Count
lRowCurrent = 0
'Loop thru every row
For i = 1 To lRows
' Read each line into an array
var() = Range(Cells(i, 1), Cells(i, lCols))
' Create a list of unique names only
On Error Resume Next
For Each a In var
arr.Add a, a
Next
'List all names
lCounter = arr.Count
For b = 1 To lCounter
Cells(lRowCurrent + b, 7) = arr(1)
Cells(lRowCurrent + b, 8) = arr(b)
Next
Set arr = Nothing
lRowCurrent = lRowCurrent + lCounter
Next
Try this:
Sub DoTranspose()
Dim r&, cnt&
Dim rng As Range, rngRow As Range, cell As Range
Set rng = Sheets("Source").Range("A1").CurrentRegion
r = 1
For Each rngRow In rng.Rows
cnt = WorksheetFunction.CountA(rngRow.Cells)
With Sheets("output").Cells(r, 1).Resize(cnt)
.Value = rngRow.Cells(1).Value
.Offset(, 1).Value = Application.Transpose(rngRow.Resize(, cnt).Value)
End With
r = r + cnt
Next
End Sub
Sample workbook.
This seems to be a simple un-pivot operation.
If you have Excel 2010+, you can use Power Query (aka Get&Transform in Excel 2016+), to do this.
Select a single cell in the table
Data / Get & Transform / From Range should select the entire table
Select the first column in the Query table.
Transform / Unpivot other columns
Delete the unwanted column
Save and Load
(Takes longer to type than to do)
This is the M Code, but you can do it all from the PQ GUI:
let
Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
#"Changed Type" = Table.TransformColumnTypes(Source,{{"Column1", type text}, {"Column2", type text}, {"Column3", type text}, {"Column4", type text}}),
#"Unpivoted Other Columns" = Table.UnpivotOtherColumns(#"Changed Type", {"Column1"}, "Attribute", "Value"),
#"Removed Columns" = Table.RemoveColumns(#"Unpivoted Other Columns",{"Attribute"})
in
#"Removed Columns"
Original Data
Unpivoted
Range Array Array Range
A Picture is Worth a Thousand Words
The left worksheet is the initial worksheet, and the right the resulting one.
Since cBlnColors is set to True, several ranges are being colored to better understand how this code works and to indicate the upsides of having headers.
The light yellow color represents the data range, while the yellow color represents the rest of the off limits cells.
All not colored cells can be used without affecting the results in the right worksheet.
cBlnHeadersBelow set to True means that the data is above the headers (unusual), while set to False would mean that the data will be below the headers (as usual).
Headers Below Data with Colors
Another Thousand
The following picture shows the same code used with cBlnHeadersBelow set to False.
The yellow range spans down to the last row (not visible).
Again, all not colored cells can be used without affecting the results in the right worksheet.
Headers Above Data with Colors
The Code
Option Explicit
'*******************************************************************************
' Purpose: In a specified worksheet of a specified workbook, transposes a
' range of data (vertical table!?) to a two-column range in a newly
' created worksheet.
' Arguments (As Constants):
' cStrFile
' The path of the workbook file. If "", then ActiveWorkbook is used.
' cVarWs
' It is declared as variant to be able to use both, the title
' (a string e.g. "Sheet1") or the index (a positive whole number e.g. 1)
' of the worksheet. If "", then ActiveSheet is used.
' cStrTitle
' The contents of the first cell in the headers to be searched for.
' cBlnHeaders
' If True, USE headers.
' If False, do NOT use headers i.e. cBlnHeadersBelow has no effect and the
' first data found by searching by column from "A1" is used as first cell
' and the last found data on the worksheet is used for last cell.
' cBlnHeadersBelow
' If True, the data is ABOVE the headers (Data-Then-Headers).
' If False, the data is as usual BELOW the headers (Headers-Then-Data).
' cStrPaste
' The cell address of the first cell of the resulting range in the new
' worksheet.
' cBlnColors
' If True, and cBlnHeaders is True, then colors are being used i.e. one
' color for the data range, and another for off limits ranges.
' If True, and cBlnHeaders is False, all cells are off limits,
' so only the data range is colored.
' Returns
' A new worksheet with resulting data. No threat to the initial worksheet.
' If you don't like the result, just close the workbook.
'*******************************************************************************
Sub VendorFinder()
Application.ScreenUpdating = False
'***************************************
' Variables
'***************************************
Const cStrFile As String = "" ' "Z:\arrInit List.xlsx"
Const cVarWs As Variant = 1 ' "" for ActiveSheet.
Const cStrTitle As String = "Business" ' Contents of First Cell of Header
Const cBlnHeaders As Boolean = True ' True for Headers
Const cBlnHeadersBelow As Boolean = True ' True for Headers Below Data
Const cStrPaste As String = "A1" ' Resulting First Cell Address
Const cBlnColors As Boolean = True ' Activate Colors
Dim objWb As Workbook ' Workbook to be processed
Dim objWs As Worksheet ' Worksheet to be processed
Dim objTitle As Range ' First Cell of Header
Dim objFirst As Range ' First Cell of Data
Dim objLast As Range ' Last Cell of Data
Dim objResult As Range ' Resulting Range
Dim arrInit As Variant ' Array of Initial Data
Dim arrResult() As Variant ' Array of Resulting Data
Dim lngRows As Long ' Array Rows Counter
Dim iCols As Integer ' Array Columns Counter
Dim lngVendor As Long ' Array Data Counter, Array Row Counter
' ' Debug
' Const r1 As String = vbCr ' Debug Rows Separator
' Const c1 As String = "," ' Debug Columns Separator
'
' Dim str1 As String ' Debug String Builder
' Dim lng1 As Long ' Debug Rows Counter
' Dim i1 As Integer ' Debug Columns Counter
'***************************************
' Workbook
'***************************************
'On Error GoTo WorkbookErr
If cStrFile <> "" Then
Set objWb = Workbooks.Open(cStrFile)
Else
Set objWb = ActiveWorkbook
End If
'***************************************
' Worksheet
'***************************************
' On Error GoTo WorksheetErr
If cVarWs <> "" Then
Set objWs = objWb.Worksheets(cVarWs)
Else
Set objWs = objWb.ActiveSheet
End If
With objWs
' Colors
If cBlnColors = True Then
Dim lngData As Variant: lngData = RGB(255, 255, 153)
Dim lngOffLimits As Variant: lngOffLimits = RGB(255, 255, 0)
Else
.Cells.Interior.ColorIndex = xlNone
End If
' Assumptions:
' 1. Headers is a contiguous range.
' 2. The Headers Title is the first cell of Headers i.e. the first cell
' where cStrTitle is found while searching by rows starting from cell
' "A1".
' 3. The Headers Range spans from the Headers Title to the last cell,
' containing data, on the right.
' 4. All cells to the left and to the right of the Headers Range except
' for the cell adjacent to the right are free to be used i.e. no
' calculation is performed on them. If cBlnHeadersBelow is set to True,
' the cells below the Headers Range are free to be used. Similarly,
' if cBlnHeadersBelow is set to False the cells above are free to be
' used.
' 5. When cBlnHeadersBelow is set to True, the first row of data is
' calculated just using the column of the Headers Title
If cBlnHeaders = True Then ' USE Headers.
' Calculate Headers Title (using cStrTitle as criteria).
Set objTitle = .Cells _
.Find(What:=cStrTitle, After:=.Cells(.Rows.Count, .Columns.Count), _
LookIn:=xlFormulas, Lookat:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext)
' Calculate initial first and last cells of data.
If cBlnHeadersBelow Then ' Headers are below data.
' Search for data in column of Headers Title starting from the first
' worksheet's row forwards to the row of Headers Title.
' When first data is found, the first cell is determined.
Set objFirst = .Range(.Cells(1, objTitle.Column), objTitle) _
.Find(What:="*", After:=.Cells(objTitle.Row, objTitle.Column), _
LookIn:=xlFormulas, Lookat:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext)
' xlToRight, indicating that Headers Range is contiguous, uses the
' last cell of Headers Range while -1 sets the cells' row, one row above
' the Headers Title, resulting in the last cell range.
Set objLast = objTitle.End(xlToRight).Offset(-1, 0)
' Colors
If cBlnColors = True Then
.Cells.Interior.ColorIndex = xlNone
If objFirst.Row > 1 Then
.Range(.Cells(1, objFirst.Column), _
.Cells(objFirst.Row - 1, objLast.Column)) _
.Interior.color = lngOffLimits
End If
If objLast.Column < .Columns.Count Then
.Range(objTitle, .Cells(objTitle.Row, objLast.Column + 1)) _
.Interior.color = lngOffLimits
Else
.Range(objTitle, .Cells(objTitle.Row, objLast.Column)) _
.Interior.color = lngOffLimits
End If
.Range(objFirst, objLast).Interior.color = lngData
End If
Else ' Headers are above data (usually).
' 1 sets the cells' row, one row below the Headers Title
' resulting in the first cell range.
Set objFirst = objTitle.Offset(1, 0)
' Search for data in column of Headers Title starting from the last
' worksheet's row backwards to the row of Headers Title.
' When first data is found, the last row is determined and combined
' with the last column results in the last cell range.
Set objLast = .Cells( _
.Range(objTitle, .Cells(.Rows.Count, _
objTitle.End(xlToRight).Column)) _
.Find(What:="*", After:=objTitle, _
LookIn:=xlFormulas, Lookat:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious) _
.Row, _
_
objTitle.End(xlToRight) _
.Column)
'Colors
If cBlnColors = True Then
.Cells.Interior.ColorIndex = xlNone
If objLast.Row < .Rows.Count Then
.Range(.Cells(objLast.Row + 1, objFirst.Column), _
.Cells(.Rows.Count, objLast.Column)) _
.Interior.color = lngOffLimits
End If
If objLast.Column < .Columns.Count Then
.Range(objTitle, .Cells(objTitle.Row, objLast.Column + 1)) _
.Interior.color = lngOffLimits
Else
.Range(objTitle, .Cells(objTitle.Row, objLast.Column)) _
.Interior.color = lngOffLimits
End If
.Range(objFirst, objLast).Interior.color = lngData
End If
End If
Else ' Do NOT use headers.
' Search for data in any cell from "A1" by column. When first data is
' found, the first cell is determined.
Set objFirst = _
.Cells _
.Find(What:="*", After:=.Cells(.Rows.Count, .Columns.Count), _
LookIn:=xlFormulas, Lookat:=xlWhole, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext)
' Last cell with data on the worksheet.
Set objLast = .Cells( _
_
.Cells _
.Find(What:="*", After:=.Cells(1, 1), _
LookIn:=xlFormulas, Lookat:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious) _
.Row, _
_
.Cells _
.Find(What:="*", After:=.Cells(1, 1), _
LookIn:=xlFormulas, Lookat:=xlWhole, _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious) _
.Column)
' Colors
If cBlnColors = True Then
.Cells.Interior.ColorIndex = xlNone
Range(objFirst, objLast).Interior.color = lngData
End If
End If
End With
'***************************************
' arrInit
'***************************************
' On Error GoTo arrInitErr
' Paste the values (Value2) of initial range into initial array (arrInit).
arrInit = Range(objFirst, objLast).Value2
' ' Debug
' str1 = r1 & "Initial Array (arrInit)" & r1
' For lng1 = LBound(arrInit) To UBound(arrInit)
' str1 = str1 & r1
' For i1 = LBound(arrInit, 2) To UBound(arrInit, 2)
' If i1 <> 1 Then
' str1 = str1 & c1
' End If
' str1 = str1 & arrInit(lng1, i1)
' Next
' Next
' Debug.Print str1
' Count data in arrInit.
For lngRows = LBound(arrInit) To UBound(arrInit)
For iCols = LBound(arrInit, 2) To UBound(arrInit, 2)
If arrInit(lngRows, iCols) <> "" Then
lngVendor = lngVendor + 1
End If
Next
Next
'***************************************
' arrResult
'***************************************
' On Error GoTo arrResultErr
ReDim arrResult(1 To lngVendor, 1 To 2) ' Resize resulting array (arrResult).
lngVendor = 0 ' Reset array data counter to be used as array row counter.
' Loop through arrInit and write to arrResult.
For lngRows = LBound(arrInit) To UBound(arrInit)
For iCols = LBound(arrInit, 2) To UBound(arrInit, 2)
If arrInit(lngRows, iCols) <> "" Then
lngVendor = lngVendor + 1
If iCols = 1 Then
arrResult(lngVendor, 1) = arrInit(lngRows, iCols)
Else
arrResult(lngVendor, 1) = arrResult(lngVendor - 1, 1)
End If
arrResult(lngVendor, 2) = arrInit(lngRows, iCols)
End If
Next
Next
Erase arrInit ' Data is in arrResult.
' ' Debug
' str1 = r1 & "Resulting Array (arrResult)" & r1
' For lng1 = LBound(arrResult) To UBound(arrResult)
' str1 = str1 & r1
' For i1 = LBound(arrResult, 2) To UBound(arrResult, 2)
' If i1 <> 1 Then
' str1 = str1 & c1
' End If
' str1 = str1 & arrResult(lng1, i1)
' Next
' Next
' Debug.Print str1
' Since there is only an infinite number of possibilities what to do with the
' resulting array, pasting it into a new worksheet has been chosen to be able
' to apply the bold formatting of the "Business Names" requested.
'***************************************
' New Worksheet
'***************************************
On Error GoTo NewWorksheetErr
Worksheets.Add After:=objWs
Set objResult = ActiveSheet.Range(Range(cStrPaste), _
Range(cStrPaste).Offset(UBound(arrResult) - 1, _
UBound(arrResult, 2) - 1))
With objResult
' Paste arrResult into resulting range (objResult).
.Value2 = arrResult
' Apply some formatting.
For lngRows = LBound(arrResult) To UBound(arrResult)
' If .Cells(lngRows, 1) = .Cells(lngRows, 2) Then ' Too slow!
If arrResult(lngRows, 1) = arrResult(lngRows, 2) Then
.Cells(lngRows, 1).Font.Bold = True
End If
Next
Erase arrResult ' Data is in objResult.
.Columns.AutoFit
End With
' To suppress the "Do you want to save changes you made to ... ?" - Alert:
objWb.Saved = True
'***************************************
' Clean Up
'***************************************
NewWorksheetExit:
Set objResult = Nothing
WorksheetExit:
Set objLast = Nothing
Set objFirst = Nothing
Set objTitle = Nothing
Set objWs = Nothing
WorkbookExit:
Set objWb = Nothing
Application.ScreenUpdating = True
Exit Sub
'***************************************
' Errors
'***************************************
WorkbookErr:
MsgBox "Workbook Error" & " (Error: '" & Err.Number & "')"
GoTo WorkbookExit
WorksheetErr:
MsgBox "Worksheet Error" & " (Error: '" & Err.Number & "')"
GoTo WorksheetExit
arrInitErr:
MsgBox "arrInit Error" & " (Error: '" & Err.Number & "')"
GoTo WorksheetExit
arrResultErr:
MsgBox "arrResult Error" & " (Error: '" & Err.Number & "')"
GoTo WorksheetExit
NewWorksheetErr:
MsgBox "New Worksheet Error" & " (Error: '" & Err.Number & "')"
GoTo NewWorksheetExit
End Sub
'*******************************************************************************
Extras
While testing the code, there were a little too many many worksheets in the workbook so I wrote this:
'*******************************************************************************
' Purpose: Deletes all Worksheets in the ActiveWorkbook except one.
' Danger: This code doesn't ask anything, it just does. In the end you will
' end up with just one worksheet (cStrWsExcept) in the workbook
' (cStrWbPath). If you have executed this code and the result is not
' satisfactory, just close the workbook and try again or don't. There
' will be no alert like "Do you want to save ..." because of the line:
' ".Saved = True" i.e. "objWb.Saved = True".
' Arguments (As Constants):
' cStrWbPath
' The path of the workbook to be processed. If "", then ActiveWorkbook is
' used.
' cStrWsExcept
' The worksheet not to be deleted. If "", then the Activesheet is used.
'*******************************************************************************
Sub DeleteWorksheetsExceptOne()
Const cStrWbPath = "" ' if "" then ActiveWorkbook
Const cStrWsExcept = "Sheet1" ' if "" then ActiveSheet
Dim objWb As Workbook
Dim objWsExcept As Worksheet
Dim objWsDelete As Worksheet
If cStrWbPath = "" Then
Set objWb = ActiveWorkbook
Else
Set objWb = Workbooks(cStrWbPath)
End If
With objWb
If cStrWsExcept = "" Then
Set objWsExcept = .ActiveSheet
Else
Set objWsExcept = .Worksheets(cStrWsExcept)
End If
' To suppress the "Data may exist in the sheet(s) selected for deletion.
' To permanently delete the data, press Delete." - Alert:
Application.DisplayAlerts = False
For Each objWsDelete In .Worksheets
If objWsDelete.Name <> objWsExcept.Name Then
objWsDelete.Delete
End If
Next
' To suppress the "Do you want to save changes you made to ... ?" - Alert:
.Saved = True
Application.DisplayAlerts = True
End With
End Sub
'*******************************************************************************

Resources