This is the "largest" VBA project I've worked on, but perhaps not the most complicated. The meat and potatoes of it basically copies and pastes data from 2 source tabs into 1. A large piece of the code was broken out and refactored into sub procedures. Variables such as "DEM_Name" are dummy names. The main sub is called GenerateLFF. I welcome any feedback where possible but I'm looking for the following:
- Performance: The performance was greatly improved by using the
performance_Optsub procedure. Even though I haven't tested it with a large data set, it takes 5-6 seconds to work with 5 records. - Improving the
copy_pastesub procedure. This is the sub referenced the most, and I'm wondering if there is any other way of writing it to improve performance. - Sub procedures: Initially, I would never break out VBA into sub procedures. Now, I might be over doing it. Does breaking out code into may subs hurt performance?
Public Const DEM_WS As String = "DEM_NAME"
Public Const PTI_WS As String = "PTI_NAME"
Public Const LFF_WS As String = "LFF_NAME"
Public DEM_ERow As Integer
Sub GenerateLFF()
'last row of DEM
DEM_ERow = Sheets(DEM_WS).Range("C4", Sheets(DEM_WS).Range("C4").End(xlDown)).Rows.Count + 3
performance_Opt True
Call format_data_tabs
Call copy_data
Call COPY_CONST
Call CO_BUYER_CONST
Call Edge_Cases
Call Formatting
Call Clear_Contents
performance_Opt False
End Sub
Sub performance_Opt(TurnOn As Boolean)
With Application
.Calculation = IIf(TurnOn, xlCalculationManual, xlCalculationAutomatic)
.ScreenUpdating = Not TurnOn
.DisplayStatusBar = Not TurnOn
.EnableEvents = Not TurnOn
End With
ActiveSheet.DisplayPageBreaks = Not TurnOn
End Sub
Private Function Header_Verification() As Boolean
'Set Wrong as string to contain all wrong columns
Dim Wrong As String
'This is a check to ensure the column headers where we are copying data from are what we mapped them to be
Wrong = ""
Set wsDEM = Sheets("DEM_NAME")
Set wsPTI = Sheets("PTI_NAME")
'*** header verification
If wsDEM.Range("E3") <> "CSC Account Number" Then Wrong = Wrong & "CSC Account Number: DEM E" & vbCrLf
If wsDEM.Range("F3") <> "Last Name" Then Wrong = Wrong & "Last Name: DEM F" & vbCrLf
If wsDEM.Range("G3") <> "First Name" Then Wrong = Wrong & "First Name: DEM G" & vbCrLf
If wsDEM.Range("H3") <> "Loan Date" Then Wrong = Wrong & "Loan Date" & vbCrLf
If wsDEM.Range("K3") <> "APR" Then Wrong = Wrong & "APR: DEM K" & vbCrLf
If wsDEM.Range("M3") <> "Amt Financed" Then Wrong = Wrong & "Amt Financed: DEM M" & vbCrLf
If wsDEM.Range("Q3") <> "Number of Payments" Then Wrong = Wrong & "Number of Payments: DEM Q" & vbCrLf
If wsDEM.Range("R3") <> "Freq" Then Wrong = Wrong & "Freq: DEM R" & vbCrLf
If wsDEM.Range("AL3") <> "Vehicle Year" Then Wrong = Wrong & "Vehicle Year: DEM AL" & vbCrLf
If wsDEM.Range("AM3") <> "Make" Then Wrong = Wrong & "Make: DEM AM" & vbCrLf
If wsDEM.Range("AN3") <> "Model" Then Wrong = Wrong & "Model: DEM AN" & vbCrLf
If wsDEM.Range("AO3") <> "Vin" Then Wrong = Wrong & "Vin: DEM AO" & vbCrLf
If wsDEM.Range("BE3") <> "Co- buyer First Name" Then Wrong = Wrong & "Co- buyer First Name: DEM BC" & vbCrLf
If wsDEM.Range("BF3") <> "Co Buyer Last Name" Then Wrong = Wrong & "Co Buyer Last Name: DEM BD" & vbCrLf
If wsDEM.Range("BG3") <> "CoBuyer Address" Then Wrong = Wrong & "CoBuyer Address: DEM BE" & vbCrLf
If wsDEM.Range("BH3") <> "Co Buyer City" Then Wrong = Wrong & "Co Buyer City" & vbCrLf
If wsDEM.Range("BI3") <> "Co Buyer State" Then Wrong = Wrong & "Co Buyer State: DEM BG" & vbCrLf
If wsDEM.Range("BJ3") <> "Co Buyer Zip" Then Wrong = Wrong & "Co Buyer Zip: DEM BH" & vbCrLf
If wsDEM.Range("BK3") <> "Co Buyer Social" Then Wrong = Wrong & "Co Buyer Social: DEM BI" & vbCrLf
If wsDEM.Range("BL3") <> "Co Buyer DOB" Then Wrong = Wrong & "Co Buyer DOB: DEM BJ" & vbCrLf
If wsDEM.Range("BM3") <> "Schedule 1 PMT Freq" Then Wrong = Wrong & "Schedule 1 PMT Freq: DEM BM" & vbCrLf
If wsDEM.Range("BN3") <> "Schedule 1 Number of PMT's" Then Wrong = Wrong & "Schedule 1 Number of PMT's: DEM BN" & vbCrLf
If wsDEM.Range("BO3") <> "Schedule 1 PMT Amount" Then Wrong = Wrong & "Schedule 1 PMT Amount: DEM BO" & vbCrLf
If wsDEM.Range("BP3") <> "Schedule 1 PMT Start Date" Then Wrong = Wrong & "Schedule 1 PMT Start date: DEM BP" & vbCrLf
If wsDEM.Range("BQ3") <> "Schedule 2 PMT Freq" Then Wrong = Wrong & "Schedule 2 PMT Freq: DEM BQ" & vbCrLf
If wsDEM.Range("BR3") <> "Schedule 2 Number of PMT's" Then Wrong = Wrong & "Schedule 2 Number of PMT's: DEM BR" & vbCrLf
If wsDEM.Range("BS3") <> "Schedule 2 PMT Amount" Then Wrong = Wrong & "Schedule 2 PMT Amount: DEM BS" & vbCrLf
If wsDEM.Range("BT3") <> "Schedule 2 PMT Start Date" Then Wrong = Wrong & "Schedule 2 PMT Start date: DEM BT" & vbCrLf
If wsDEM.Range("BV3") <> "Schedule 3 PMT Start Date" Then Wrong = Wrong & "Schedule 3 PMT Start date: DEM BV" & vbCrLf
'*** header verification ***
If wsPTI.Range("BQ1") <> "Cus Address" Then Wrong = Wrong & "Cus Address: PTI BQ" & vbCrLf
If wsPTI.Range("BR1") <> "City" Then Wrong = Wrong & "City: PTI BR" & vbCrLf
If wsPTI.Range("BS1") <> "State" Then Wrong = Wrong & "State: PTI BS" & vbCrLf
If wsPTI.Range("BT1") <> "Zip Code" Then Wrong = Wrong & "Zip Code: PTI BT" & vbCrLf
If wsPTI.Range("BU1") <> "Phone (Home)" Then Wrong = Wrong & "Phone (Home): PTI BU" & vbCrLf
If wsPTI.Range("BV1") <> "Phone (Cell)" Then Wrong = Wrong & "Phone (Cell): PTI BV" & vbCrLf
If wsPTI.Range("CD1") <> "Employer Phone" Then Wrong = Wrong & "Employer Phone: PTI CD" & vbCrLf
If wsPTI.Range("CF1") <> "Social Security #" Then Wrong = Wrong & "Social Security #: PTI CF" & vbCrLf
If wsPTI.Range("CG1") <> "Date of Birth" Then Wrong = Wrong & "Date of Birth: PTI CG" & vbCrLf
If Wrong <> "" Then
MsgBox "Please check the following columns:" & vbCrLf & Wrong
Header_Verification = False
Else
Header_Verification = True
End If
End Function
Private Sub Filter_Blank(ByVal sheetName As String, ByVal filter_Range As String, ByVal FilterIndex As Integer)
'*** Make sure that the column contains only blanks and loan records, nothing else
Sheets(sheetName).Select
Sheets(sheetName).Range(filter_Range, Range(filter_Range).End(xlToRight)).Select
Selection.AutoFilter Field:=FilterIndex, Criteria1:="<>"
End Sub
Private Sub format_data_tabs()
If Sheets(PTI_WS).Visible <> xlSheetVisible Then Sheets(PTI_WS).Visible = xlSheetVisible
'Insert Loan Feed File tab
Sheets.Add
ActiveSheet.Name = LFF_WS
Call Filter_Blank(DEM_WS, "A3", 13)
Call sort_Asc(DEM_WS, "D3")
Call Filter_Blank(PTI_WS, "B1", 10)
Call sort_Asc(PTI_WS, "B1")
If Header_Verification = False Then End
Call match_hide_records(DEM_NAME, "B2", PTI_NAME, "D4")
End Sub
Private Sub sort_Asc(ByVal sheetName As String, ByVal filter_Range As String)
Dim target_range As Range
Set target_range = Range(filter_Range, Range(filter_Range).End(xlDown))
Sheets(sheetName).Select
With Sheets(sheetName).AutoFilter.Sort
.SortFields.Clear
.SortFields.Add Key:=target_range, Order:=xlAscending
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Private Sub match_hide_records(ByVal broad_list_wbName As String, ByVal broad_list_cell As String, ByVal narrow_list_wbName As String, ByVal narrow_list_cell As String)
Dim broadList As Range
Dim narrowList As Range
Dim broad_wbName As Worksheet
Dim narrow_wbName As Worksheet
Set broad_wbName = Sheets(broad_list_wbName)
Set narrow_wbName = Sheets(narrow_list_wbName)
broad_wbName.Activate
Set broadList = broad_wbName.Range(broad_list_cell, Range(broad_list_cell).End(xlDown))
narrow_wbName.Activate
Set narrowList = narrow_wbName.Range(narrow_list_cell, Range(narrow_list_cell).End(xlDown))
'match and hide
For Each cell In broadList
cell_match = Application.Match(cell.Value, narrowList, 0)
If IsNumeric(cell_match) = False Then
cell.EntireRow.Hidden = True
End If
Next cell
End Sub
Private Sub copy_data()
Call copy_paste(DEM_WS, "E4", "A2")
Call copy_paste(DEM_WS, "F4", "B2")
Call copy_paste(DEM_WS, "G4", "C2")
Call copy_paste(PTI_WS, "BQ2", "F2")
Call copy_paste(PTI_WS, "BR2", "G2")
Call copy_paste(PTI_WS, "BS2", "H2")
Call copy_paste(PTI_WS, "BT2", "I2")
Call copy_paste(PTI_WS, "CG2", "P2")
Call copy_paste(PTI_WS, "CG2", "BN2")
Call copy_paste(DEM_WS, "BL4", "V2")
Call copy_paste(DEM_WS, "BJ4", "AC2")
Call copy_paste(DEM_WS, "BH4", "AE2")
Call copy_paste(DEM_WS, "BE4", "AH2")
Call copy_paste(DEM_WS, "BF4", "AK2")
Call copy_paste(DEM_WS, "BI4", "AN2")
Call copy_paste(DEM_WS, "J4", "FK2")
Call copy_paste(DEM_WS, "AO4", "FN2")
Call copy_paste(DEM_WS, "BP4", "EX2")
Call copy_paste(DEM_WS, "BT4", "EY2")
Call copy_paste(DEM_WS, "BV4", "EZ2")
Call copy_paste(DEM_WS, "BO4", "DZ2")
Call copy_paste(DEM_WS, "BS4", "EA2")
Call copy_paste(DEM_WS, "BU4", "EB2")
Call copy_paste(DEM_WS, "BN4", "EH2")
Call copy_paste(DEM_WS, "BR4", "EI2")
Call copy_paste(DEM_WS, "AN4", "DB2")
Call copy_paste(DEM_WS, "H4", "AW2")
Call copy_paste(DEM_WS, "H4", "DN2")
Call copy_paste(DEM_WS, "M4", "DY2")
Call copy_paste(PTI_WS, "CD2", "Q2")
Call copy_paste(PTI_WS, "BW2", "S2")
Call copy_paste(PTI_WS, "BU2", "BB2")
Call copy_paste(DEM_WS, "K4", "BK2")
Call copy_paste(DEM_WS, "AM4", "CY2")
Call copy_paste(DEM_WS, "AL4", "DC2")
Call copy_paste(DEM_WS, "T4", "BE2")
Call copy_paste(DEM_WS, "R4", "DO2")
Call copy_paste(LFF_WS, "BK2", "FF2")
Call copy_paste(LFF_WS, "DV2", "EP2")
Call copy_paste(LFF_WS, "DV2", "EQ2")
Call copy_paste(DEM_WS, "R4", "CL2")
Call copy_paste(DEM_WS, "T4", "FI2")
Call copy_paste(DEM_WS, "Q4", "FJ2")
Call copy_paste(DEM_WS, "L4", "FS2")
Call copy_paste(DEM_WS, "R4", "DV2")
End Sub
Private Sub copy_paste(ByVal src_sheetname As String, ByVal src_cell As String, ByVal dst_cell As String)
Dim dst_sheetName As Worksheet
Set dst_sheetName = Sheets("Loan Feed File Output")
Dim src_column As String
src_column = Left(src_cell, Len(src_cell) - 1)
Dim target_range As String
target_range = src_cell & ":" & src_column & DEM_ERow
Sheets(src_sheetname).Range(target_range).Copy
dst_sheetName.Range(dst_cell).PasteSpecial Paste:=xlPasteValues
End Sub
Private Sub COPY_CONST()
Call CONST_DATA("J", "US")
Call CONST_DATA("M", "'000000000")
Call CONST_DATA("N", "'0")
Call CONST_DATA("T", "'0")
Call CONST_DATA("U", "'0000000.00")
Call CONST_DATA("AR", "'0000000.00")
Call CONST_DATA("AS", "'0000000.00")
Call CONST_DATA("AT", "'0000000.00")
Call CONST_DATA("AV", "'.00000")
Call CONST_DATA("AZ", "'001")
Call CONST_DATA("BC", "'0000000.00")
Call CONST_DATA("BH", "'000000000.00")
Call CONST_DATA("BI", "'0")
Call CONST_DATA("BJ", "'.00000")
Call CONST_DATA("BO", "'00")
Call CONST_DATA("BP", "'0000000000000")
Call CONST_DATA("BQ", "'0000000000000")
Call CONST_DATA("BV", "'0.0000")
Call CONST_DATA("CA", "'0000000.00")
Call CONST_DATA("CB", "'0000000.00")
Call CONST_DATA("CC", "'0000000.00")
Call CONST_DATA("CE", "A")
Call CONST_DATA("CF", "'1")
Call CONST_DATA("CH", "'0000000.00000000")
Call CONST_DATA("CI", "'.00000")
Call CONST_DATA("CJ", "'000001")
Call CONST_DATA("DD", "'000")
Call CONST_DATA("DK", "'000")
Call CONST_DATA("DA", "'3")
Call CONST_DATA("FG", "8880")
Call CONST_DATA("DI", "U")
Call CONST_DATA("BF", Sheets("Home").Range("B6").Value)
End Sub
Private Sub CONST_DATA(ByVal dst_col As String, ByVal str_value As String)
Dim target_range As String
target_range = dst_col & "2:" & dst_col & (DEM_ERow - 2)
Sheets(LFF_WS).Range(target_range).Value = str_value
End Sub
Private Sub CO_BUYER_CONST()
Sheets(LFF_WS).Select
Dim co_buyer_range As Range
Set co_buyer_range = Sheets(LFF_WS).Range("AH2:AH" & DEM_ERow)
For Each cell In co_buyer_range
If IsEmpty(cell) = False Then
Range("AG" & cell.Row).Value = "US" 'CO_BUYER_COUNTRY
Range("AO" & cell.Row).Value = "'0001" 'COLL
Range("AP" & cell.Row).Value = "'0" 'COMAKER_CE
End If
Next cell
End Sub
Private Sub CSC_AccountNubmer_EdgeCase(ByVal strRange As String)
'Returns 7 digits from the CSC Account number
Dim CSC_Range As Range
Set CSC_Range = Sheets(LFF_WS).Range(strRange & "2:" & strRange & DEM_ERow - 2)
For Each cell In CSC_Range
cell.Value = Mid(cell.Value, 7, 7)
Next cell
End Sub
Private Sub LateChgCode_EdgeCase(ByVal strRange As String)
'Retrieves the state code from the state code list located in tab "Raw 1"
Dim State_Code_Range As Range
Set State_Code_Range = Sheets(LFF_WS).Range(strRange & "2:" & strRange & DEM_ERow - 2)
For Each cell In State_Code_Range
cell.Value = Application.Index(Sheets("Raw 1").Range("Y5:AE56"), Application.Match(cell.Value, Sheets("Raw 1").Range("Y5:Y56"), 0), 7)
Next cell
End Sub
Private Sub Percent_EdgeCase(ByVal strRange As String)
'Checks APR formatting and if not decimal, decimal
Dim APR_Range As Range
Set APR_Range = Sheets(LFF_WS).Range(strRange & "2:" & strRange & DEM_ERow - 2)
For Each cell In APR_Range
If cell.Value < 1 Then cell.Value = cell.Value * 100
cell.NumberFormat = "0.00"
Next cell
End Sub
Private Sub Make_Len_EdgeCase(ByVal strRange As String)
'Returns 8 characters if the Make is greater than 8 characters
Dim Make_Range As Range
Set Make_Range = Sheets(LFF_WS).Range(strRange & "2:" & strRange & DEM_ERow - 2)
For Each cell In Make_Range
If Len(cell.Value) > 8 Then cell.Value = Left(cell.Value, 8)
Next cell
End Sub
Private Sub Year_Len_EdgeCase(ByVal strRange As String)
'Returns the year as YY if the format is YYYY
Dim Year_Range As Range
Set Year_Range = Sheets(LFF_WS).Range(strRange & "2:" & strRange & DEM_ERow - 2)
For Each cell In Year_Range
cell.NumberFormat = "@"
If Len(cell.Value) > 2 Then cell.Value = Right(cell.Value, 2)
Next cell
End Sub
Private Sub Notice_EdgeCase(ByVal strRange As String)
'Returns the correct type based on the value in column DO
Dim Notice_Range As Range
Set Notice_Range = Sheets(LFF_WS).Range(strRange & "2:" & strRange & DEM_ERow - 2)
For Each cell In Notice_Range
If cell.Value = 12 Then
cell.Value = "D"
Else:
cell.Value = "'2"
End If
Next cell
End Sub
Private Sub Freq_Code_EdgeCase(ByVal strRange As String)
Dim Freq As Integer
Dim Freq_Code_Range As Range
Set Freq_Code_Range = Sheets(LFF_WS).Range(strRange & "2:" & strRange & DEM_ERow - 2)
For Each cell In Freq_Code_Range
Freq = cell.Value
Select Case Freq
Case Is = 12
cell.Value = ""
Case Is = 24
cell.Value = "PFR2"
Case Is = 26
cell.Value = "PFR8"
Case Else
cell.Value = "PFR1"
End Select
Next cell
End Sub
Private Sub PMT_Freq_EdgeCase(ByVal strRange As String)
Dim PMT_Freq As Variant 'integer or string
Dim PMT_Freq_Range As Range
Set PMT_Freq_Range = Sheets(LFF_WS).Range(strRange & "2:" & strRange & DEM_ERow - 2)
For Each cell In PMT_Freq_Range
PMT_Freq = cell.Value
Select Case PMT_Freq
Case Is = ""
cell.Value = ""
Case Is = 12
cell.Value = "'3"
Case Is = 24
cell.Value = "'2"
Case Is = 26
cell.Value = "'8"
Case Else
cell.Value = "'1"
End Select
Next cell
End Sub
Private Sub State_Code_EdgeCase(ByVal strRange As String)
'Retrieves the state code from the state code list located in tab "Raw 1"
Dim State_Code_Range As Range
Set State_Code_Range = Sheets(LFF_WS).Range(strRange & "2:" & strRange & DEM_ERow - 2)
For Each cell In State_Code_Range
cell.Value = Application.Index(Sheets("Raw 1").Range("Y5:AD56"), Application.Match(cell.Value, Sheets("Raw 1").Range("Y5:Y56"), 0), 6)
Next cell
End Sub
Private Sub LR_IntDiscount_EdgeCase(ByVal strRange As String)
' there has to be a value to compare the loans to determine if we need this value or not
Dim LR_IntDiscount_Range As Range
Set LR_IntDiscount_Range = Sheets(LFF_WS).Range(strRange & "2:" & strRange & DEM_ERow)
For Each cell In LR_IntDiscount_Range
Select Case cell.Value
Case Is = ""
cell.Value = ""
Case Is = 3
cell.Value = ""
End Select
Next cell
End Sub
Private Sub SSN_EdgeCase(ByVal src_sheetname As String, ByVal src_cell As String, ByVal dst_cell As String)
'copies and values and formatting of SSNs
Dim dst_sheetName As Worksheet
Set dst_sheetName = Sheets("Loan Feed File Output")
Dim src_column As String
src_column = Left(src_cell, Len(src_cell) - 1)
Dim target_range As String
target_range = src_cell & ":" & src_column & DEM_ERow
Sheets(src_sheetname).Range(target_range).Copy
dst_sheetName.Range(dst_cell).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
'returns dummy SSN if less than 9 chars
Dim dst_range As String
dst_range = dst_cell & "2:" & dst_cell & DEM_ERow - 2
For Each cell In Sheets(LFF_WS).Range(dst_range)
If Len(cell.Value) > 1 And Len(cell.Value) < 9 Then cell.Value = "999999999"
Next cell
End Sub
Private Sub Integer_Extraction(ByVal col_Alpha As String)
'Extracts the integers from phone numbers and SSN
Dim strRange As String
strRange = col_Alpha & "2:" & col_Alpha & DEM_ERow
Dim target_range As Range
Set target_range = Sheets(LFF_WS).Range(strRange)
Dim strInt As String
For Each cell In target_range
strInt = ""
For i = 1 To Len(cell.Value)
If Mid(cell.Value, i, 1) >= "0" And Mid(cell.Value, i, 1) <= "9" Then
strInt = strInt + Mid(cell.Value, i, 1)
End If
Next i
cell.Value = strInt
Next cell
End Sub
Private Sub date_format(ByVal col_Alpha As String)
'returns int date as date
Dim strRange As String
strRange = col_Alpha & "2:" & col_Alpha & DEM_ERow
Dim target_range As Range
Set target_range = Sheets(LFF_WS).Range(strRange)
target_range.NumberFormat = "m/d/yyyy"
End Sub
Private Sub Clear_Contents()
Dim target_range As Range
Set target_range = Sheets(LFF_WS).Range("A2:HD" & DEM_ERow - 2)
For Each cell In target_range
If cell.Value = "" Then cell.ClearContents
Next cell
End Sub
Private Sub Edge_Cases()
Call CSC_AccountNubmer_EdgeCase("A")
Call Percent_EdgeCase("FF")
Call Percent_EdgeCase("BK")
Call Year_Len_EdgeCase("DC")
Call Notice_EdgeCase("DO")
Call Freq_Code_EdgeCase("CL")
Call PMT_Freq_EdgeCase("DV")
Call State_Code_EdgeCase("FI")
Call Make_Len_EdgeCase("CY")
Call LateChgCode_EdgeCase("BE")
Call SSN_EdgeCase(PTI_WS, "CF2", "FH2")
Call SSN_EdgeCase(DEM_WS, "BK4", "AB2")
End Sub
Private Sub Formatting()
Call date_format("P")
Call date_format("AW")
Call date_format("BN")
Call date_format("DN")
Call date_format("EX")
Call date_format("V")
Call Integer_Extraction("FH")
Call Integer_Extraction("BB")
Call Integer_Extraction("Q")
End Sub
2 Answers 2
Your variable for DEM_ERow looks to be more complicated than it needs. DEM_ERow = wsDEM.Range("C4").End(xlDown).Row should produce the same row count.
A lot of your Subs were passing in both the sheet name and a string that represents the range. Assume you have Private Sub BoldHeaders(ByVal topLeftCell As Range). To use it in your code you'd see BoldHeaders Sheet1.Range("A1"). If you need to access something on the sheet you can access the Parent property on the range object topLeftCell.Parent.Range(...). This helps simplify your procedures signatures.
As @Raystafarian already mentioned in his answer don't use .Select. Instead access the member directly. Sheet1.Select followed by Selection.Range("A1") or Range("A1") which uses the implicit ActiveSheet both become the fully qualified Sheet1.Range("A1"). Doing what's been mentioned on Filter_Blank it becomes
Private Sub Filter_Blank(ByVal leftmostCellInHeader As Range, ByVal FilterIndex As Integer)
Dim filterRange As Range
Set filterRange = leftmostCellInHeader.Parent.Range(leftmostCellInHeader, leftmostCellInHeader.End(xlToRight))
filterRange.AutoFilter Field:=FilterIndex, Criteria1:="<>"
End Sub
The filterRange variable is there to show how it compares with your original. It can ultimately become a single line leftmostCellInHeader.Parent.Range(leftmostCellInHeader, leftmostCellInHeader.End(xlToRight)).AutoFilter Field:=FilterIndex, Criteria1:="<>".
To continue on with refactoring (changing how code achieves the result without altering what is achieved) your code, lets look at format_data_tabs.You can update Sheets.Add and AcitveSheet.Name = ... to be a single line Sheets.Add.Name = ... since as far as I can tell nothing is being done with that sheet.
Applying refactoring to sort_Asc you can have it called sort_Asc wsPTI.Range("B1") where wsPTI is a worksheet variable that's been assigned by a line of code that I show later on.
Private Sub sort_Asc(ByVal headerOfFieldToFilter As Range)
Dim target_range As Range
Set target_range = headerOfFieldToFilter.Parent.Range(headerOfFieldToFilter, headerOfFieldToFilter.End(xlDown))
With target_range.Parent.AutoFilter.Sort
.SortFields.Clear
.SortFields.Add Key:=target_range, Order:=xlAscending
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Those changes end up with
Private Sub format_data_tabs()
If wsPTI.Visible <> xlSheetVisible Then
wsPTI.Visible = xlSheetVisible
End If
'Insert Loan Feed File tab
Dim loanFileFeed As Worksheet
Set loanFileFeed = Sheets.Add
loanFileFeed.Name = wsLFF.Name
Filter_Blank wsDEM.Range("A3"), 13
sort_Asc wsDEM.Range("D3")
Filter_Blank wsPTI.Range("B1"), 10
sort_Asc wsPTI.Range("B1")
If Header_Verification = False Then End
match_hide_records Sheets("DEM_NAME").Range("B2"), Sheets("PTI_NAME").Range("D4")
End Sub
A lot if this same refactoring can be applied throughout your code.
Looking at copy_paste you have the parameter dst_cell that's for the destinationCell. I suggest using the full descriptive name as it makes it easier to understand. The misleading part is what sheet this cell will be going to. You have to know what the internals are doing and that it has Dim dst_sheetName As Worksheet inside that's setting it to Sheets("Loan Feed File Output"). Refactoring ByVal dst_cell As String to ByVal destinationCell As Range you know which sheet the cell is coming from. My refactoring came up with
Private Sub copy_paste(ByVal sourceCell As Range, ByVal destinationCell As Range)
Dim sourceRange As Range
Set sourceRange = sourceCell.Parent.Range(sourceCell, sourceCell.Parent.Cells(DEM_ERow, sourceCell.Column))
destinationCell.Resize(sourceRange.Rows.Count).Value2 = sourceRange.Value2
End Sub
The .Copy and .PasteSpecial Paste:=xlPasteValues amounted to destinationCell.Resize(sourceRange.Rows.Count).Value2 = sourceRange.Value2 since you're only concerned about migrating the values over. An example of how it's now used
Private Sub copy_data()
Dim destinationSheet As Worksheet
Set destinationSheet = Sheets("Loan Feed File Output")
copy_paste wsDEM.Range("E4"), destinationSheet.Range("A2")
....
End Sub
Looking at CONST_DATA there is a surprise hiding inside of it. target_range = dst_col & "2:" & dst_col & (DEM_ERow - 2) has the 2 just in front of the colon and DEM_ERow - 2 begging to be converted into parameters that get supplied the values. This goes back to not needing to know implementation details, what's inside that's making it work. There were several other times that I did this for other Subs.
Private Sub CONST_DATA(ByVal updateSheet As Worksheet, ByVal destinationColumn As String, ByVal startRow As Long, ByVal endRow As Long, ByVal value As String)
With updateSheet
.Range(.Cells(startRow, destinationColumn), .Cells(endRow, destinationColumn)).Value2 = value
End With
End Sub
Now when you call this sub you know that there's a start and end row that you're working with.
Private Sub COPY_CONST()
Dim startRow As Long
startRow = 2
Dim endRow As Long
endRow = DEM_ERow - 2
Dim updateSheet As Worksheet
Set updateSheet = wsLFF
CONST_DATA updateSheet, "J", startRow, endRow, "US"
....
End Sub
CO_BUYER_CONST has Sheets(LFF_WS).Select hiding inside. A couple lines later you have Range(...) which relies on that .Select since it's implicitly using the ActiveSheet.
IsEmpty(cell) = False has been updated to Not IsEmpty(cell) since IsEmpty is a function that has a Boolean return value. Not makes a True -> False and False -> True.
Private Sub CO_BUYER_CONST(ByVal useRange As Range)
Dim cell As Range
For Each cell In useRange
If Not IsEmpty(cell) Then
With useRange.Parent
.Range("AG" & cell.Row).value = "US" 'CO_BUYER_COUNTRY
.Range("AO" & cell.Row).value = "'0001" 'COLL
.Range("AP" & cell.Row).value = "'0" 'COMAKER_CE
End With
End If
Next
End Sub
It's call site becomes CO_BUYER_CONST wsLFF.Range("AH2:AH" & DEM_ERow) letting you know what's going to be used.
The formatting call.
Private Sub date_format(ByVal useSheet As Worksheet, ByVal columnLetter As String, ByVal startRow As Long, ByVal endRow As Long)
useSheet.Range(useSheet.Cells(startRow, columnLetter), useSheet.Cells(endRow, columnLetter)).NumberFormat = "m/d/yyyy"
End Sub
Integer_Extraction was updated with a Regular Expression aka RegEx. To pull out the numbers. Regex are very powerful and very worthwhile to learn and I'd do a poor job explaining them.
Private Sub Integer_Extraction(ByVal useSheet As Worksheet, ByVal columnLetter As String, ByVal startRow As Long, ByVal endRow As Long)
'Extracts the integers from phone numbers and SSN
With useSheet
Dim target_range As Range
Set target_range = .Range(.Cells(startRow, columnLetter), .Cells(endRow, columnLetter))
End With
Dim strInt As String
Dim cell As Range
For Each cell In target_range
strInt = ""
strInt = RegexNumberExtraction(cell.Value2)
cell.value = strInt
Next
End Sub
'https://stackoverflow.com/questions/4187356/regular-expression-to-extract-numbers-from-a-string
Private Function RegexNumberExtraction(ByVal value As String) As Long
'To enable early binding which provides intellisense
'Tools>References>Microsoft VBScript Regular Expressions 5.5
'Currently late bound and doesn't need a reference set
Dim foo As Object 'VBScript_RegExp_55.RegExp
Set foo = CreateObject("vbscript.regexp") 'New VBScript_RegExp_55.RegExp
foo.Global = True
foo.Pattern = "[0-9]+"
Dim bar As Object
Set bar = foo.Execute(value)
Dim extractedNumbers As String
Dim i As Long
For i = 0 To bar.Count - 1
extractedNumbers = extractedNumbers & bar(i)
Next
RegexNumberExtraction = CLng(extractedNumbers)
End Function
Call site ends up looking like
Private Sub Formatting()
Dim startRow As Long
startRow = 2
Dim endRow As Long
endRow = DEM_ERow
Dim useSheet As Worksheet
Set useSheet = wsLFF
date_format useSheet, "P", startRow, endRow
...
Integer_Extraction useSheet, "FH", startRow, endRow
...
End Sub
All your subs with _EdgeCase I moved to a dedicated module named EdgeCases. LR_IntDiscount_EdgeCase was never used and was commented out.
'EdgeCases module
Public Sub CSC_AccountNubmer(ByVal updateSheet As Worksheet, ByVal columnLetter As String, ByVal startRow As Long, ByVal endRow As Long)
'Returns 7 digits from the CSC Account number
Dim CSC_Range As Range
With updateSheet
Set CSC_Range = .Range(.Cells(startRow, columnLetter), .Cells(endRow, columnLetter))
End With
Dim cell As Range
For Each cell In CSC_Range
cell.value = Mid$(cell.value, 7, 7)
Next
End Sub
Public Sub LateChgCode(ByVal updateSheet As Worksheet, ByVal columnLetter As String, ByVal startRow As Long, ByVal endRow As Long)
'Retrieves the state code from the state code list located in tab "Raw 1"
Dim matchLookupValues As Range
Set matchLookupValues = Sheets("Raw 1").Range("Y5:Y56")
Const EXACT_MATCH As Long = 0
Dim indexLookupValues As Range
Set indexLookupValues = Sheets("Raw 1").Range("AE5:AE56")
Dim State_Code_Range As Range
With updateSheet
Set State_Code_Range = .Range(.Cells(startRow, columnLetter), .Cells(endRow, columnLetter))
End With
Dim foundOnRow As Double
Dim cell As Range
For Each cell In State_Code_Range
foundOnRow = WorksheetFunction.Match(cell.value, matchLookupValues, EXACT_MATCH)
cell.value = WorksheetFunction.Index(indexLookupValues, foundOnRow)
Next
End Sub
Public Sub Percentage(ByVal updateSheet As Worksheet, ByVal columnLetter As String, ByVal startRow As Long, ByVal endRow As Long)
'Checks APR formatting and if not decimal, decimal
Dim APR_Range As Range
With updateSheet
Set APR_Range = .Range(.Cells(startRow, columnLetter), .Cells(endRow, columnLetter))
End With
Dim cell As Range
For Each cell In APR_Range
If cell.value < 1 Then
cell.value = cell.value * 100
End If
cell.NumberFormat = "0.00"
Next
End Sub
Public Sub Make_Len(ByVal updateSheet As Worksheet, ByVal columnLetter As String, ByVal startRow As Long, ByVal endRow As Long)
'Returns 8 characters if the Make is greater than 8 characters
Dim Make_Range As Range
With updateSheet
Set Make_Range = .Range(.Cells(startRow, columnLetter), .Cells(endRow, columnLetter))
End With
Dim cell As Range
For Each cell In Make_Range
If Len(cell.value) > 8 Then
cell.value = Left$(cell.value, 8)
End If
Next
End Sub
Public Sub Year_Len(ByVal updateSheet As Worksheet, ByVal columnLetter As String, ByVal startRow As Long, ByVal endRow As Long)
'Returns the year as YY if the format is YYYY
Dim Year_Range As Range
With updateSheet
Set Year_Range = .Range(.Cells(startRow, columnLetter), .Cells(endRow, columnLetter))
End With
Dim cell As Range
For Each cell In Year_Range
cell.NumberFormat = "@"
If Len(cell.value) > 2 Then
cell.value = Right$(cell.value, 2) 'possibly use Format$(cell.value,"YY")
End If
Next
End Sub
Public Sub Notice(ByVal updateSheet As Worksheet, ByVal columnLetter As String, ByVal startRow As Long, ByVal endRow As Long)
'Returns the correct type based on the value in column DO
Dim Notice_Range As Range
With updateSheet
Set Notice_Range = .Range(.Cells(startRow, columnLetter), .Cells(endRow, columnLetter))
End With
Dim cell As Range
For Each cell In Notice_Range
If cell.value = 12 Then
cell.value = "D"
Else
cell.value = "'2"
End If
Next
End Sub
Public Sub Freq_Code(ByVal updateSheet As Worksheet, ByVal columnLetter As String, ByVal startRow As Long, ByVal endRow As Long)
Dim Freq As Long
Dim Freq_Code_Range As Range
With updateSheet
Set Freq_Code_Range = .Range(.Cells(startRow, columnLetter), .Cells(endRow, columnLetter))
End With
Dim cell As Range
For Each cell In Freq_Code_Range
Freq = cell.value
Select Case Freq
Case Is = 12
cell.value = ""
Case Is = 24
cell.value = "PFR2"
Case Is = 26
cell.value = "PFR8"
Case Else
cell.value = "PFR1"
End Select
Next
End Sub
Public Sub PMT_Freq_EdgeCase(ByVal updateSheet As Worksheet, ByVal columnLetter As String, ByVal startRow As Long, ByVal endRow As Long)
Dim PMT_Freq As Variant 'integer or string
Dim PMT_Freq_Range As Range
With updateSheet
Set PMT_Freq_Range = .Range(.Cells(startRow, columnLetter), .Cells(endRow, columnLetter))
End With
Dim cell As Range
For Each cell In PMT_Freq_Range
PMT_Freq = cell.value
Select Case PMT_Freq
Case Is = ""
cell.value = ""
Case Is = 12
cell.value = "'3"
Case Is = 24
cell.value = "'2"
Case Is = 26
cell.value = "'8"
Case Else
cell.value = "'1"
End Select
Next
End Sub
Public Sub State_Code(ByVal updateSheet As Worksheet, ByVal columnLetter As String, ByVal startRow As Long, ByVal endRow As Long)
'Retrieves the state code from the state code list located in tab "Raw 1"
Dim matchLookupValues As Range
Set matchLookupValues = Sheets("Raw 1").Range("Y5:Y56")
Const EXACT_MATCH As Long = 0
Dim indexLookupValues As Range
Set indexLookupValues = Sheets("Raw 1").Range("AD5:AD56")
Dim State_Code_Range As Range
With updateSheet
Set State_Code_Range = .Range(.Cells(startRow, columnLetter), .Cells(endRow, columnLetter))
End With
Dim cell As Range
Dim foundOnRow As Double
For Each cell In State_Code_Range
foundOnRow = WorksheetFunction.Match(cell.value, matchLookupValues, EXACT_MATCH)
cell.value = WorksheetFunction.Index(indexLookupValues, foundOnRow)
Next
End Sub
'Private Sub LR_IntDiscount_EdgeCase(ByVal columnLetter As String)
' ' there has to be a value to compare the loans to determine if we need this value or not
' Dim LR_IntDiscount_Range As Range
' Set LR_IntDiscount_Range = wslff.Range(columnLetter & "2:" & columnLetter & DEM_ERow)
'
' Dim cell As Range
' For Each cell In LR_IntDiscount_Range
' Select Case cell.Value
' Case Is = "", Is = 3
' cell.Value = ""
' End Select
' Next
'
'End Sub
Public Sub SSN_EdgeCase(ByVal sourceSheet As Worksheet, ByVal sourceColumnLetter As String, ByVal sourceStartRow As Long, ByVal sourceEndRow As Long, _
ByVal destinationSheet As Worksheet, ByVal destinationColumnLetter As String, ByVal destinationStartRow As Long, ByVal destinationEndRow As Long)
'copies and values and formatting of SSNs
'returns dummy SSN if less than 9 chars
Const dummySSN As String = "999999999"
Dim copyRange As Range
With sourceSheet
Set copyRange = .Range(.Cells(sourceStartRow, sourceColumnLetter), .Cells(sourceEndRow, sourceColumnLetter)).Copy
End With
copyRange.Copy
destinationSheet.Range(destinationColumnLetter).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
Dim destination As Range
With destinationSheet
Set destination = .Range(.Cells(destinationStartRow, destinationColumnLetter), .Cells(destinationEndRow, destinationColumnLetter))
End With
Dim cell As Range
For Each cell In destination
If Len(cell.value) > 1 And Len(cell.value) < 9 Then
cell.value = dummySSN
End If
Next
End Sub
Now called as ModuleName.SubProcedureName
Private Sub Edge_Cases()
Dim startRow As Long
startRow = 2
Dim endRow As Long
endRow = DEM_ERow - 2
Dim updateSheet As Worksheet
Set updateSheet = wsLFF
EdgeCases.CSC_AccountNubmer updateSheet, "A", startRow, endRow
...
EdgeCases.SSN_EdgeCase wsPTI, "CF", 2, DEM_ERow, Sheets("Loan Feed File Output"), "FH2", startRow, endRow
...
End Sub
Circling back to the start of all of your code it now has 3 private variables for the worksheets in place of passing the names around. They are assigned at the start. I assumed that DEM_ERow can be made private.
Private DEM_ERow As Long
Private wsDEM As Worksheet
Private wsPTI As Worksheet
Private wsLFF As Worksheet
Sub GenerateLFF()
Set wsDEM = Sheets("DEM_NAME")
Set wsPTI = Sheets("PTI_NAME")
Set wsLFF = Sheets("LFF_NAME")
'last row of DEM
DEM_ERow = wsDEM.Range("C4").End(xlDown).Row
performance_Opt True
format_data_tabs
copy_data
COPY_CONST
CO_BUYER_CONST wsLFF.Range("AH2:AH" & DEM_ERow)
Edge_Cases
Formatting
Clear_Contents wsLFF, 2, DEM_ERow - 2
performance_Opt False
End Sub
These are any Subs I didn't comment on directly or forgot to mention in their respective spots.
Private Sub match_hide_records(ByVal broadCell As Range, ByVal narrowCell As Range)
Dim broadList As Range
Set broadList = broadCell.Parent.Range(broadCell, broadCell.End(xlDown))
Dim narrowList As Range
Set narrowList = narrowCell.Parent.Range(narrowCell, narrowCell.End(xlDown))
'match and hide
Dim cell As Range
For Each cell In broadList
Dim isFound As Range
Set isFound = narrowList.Find(cell.value, LookIn:=xlFormulas, LookAt:=xlWhole)
If isFound Is Nothing Then
cell.EntireRow.Hidden = True
End If
Next
End Sub
I believe that Clear_Contents can be removed entirely. From what I've seen PMT_Freq_EdgeCase and Freq_Code are using it to assign the cell value. Note that vbNullString achieves the same thing and it's not ambiguous if there was something inside the quotes that was accidentally removed. Seeing cell.Value2 = vbNullString leaves no doubt it was intentional whereas cell.Value2 = "" leaves me wondering. I'm assuming you're doing this to still allow use of the range being contiguous and Range.End(). Best bet IMO is to cell.ClearContents and refactor your code so that it's not using this temp solution. Without seeing your sheet this is as far as I can confidently make suggestions.
The Rubberduck addin for the VBA IDE caught the following I missed with its Code Inspections:
- Mid$(), Left$(), Right$()
- Missing ByVal on several parameters
performance_Opt(TurnOn As Boolean)is one. It also comes up with the implicitly passed by reference FilterIndex As IntegerIntegers can/should be declared asLongunless mandated to beInteger.performance_Optis implicitly public because it's missing an access modifier.GenerateLFFshould be prefaced withPublicto make it explicitly known that it's public (assuming you're calling it via a button).- Lots of implicit references of ActiveWorkbook on
Sheets. I'd say they can all be madeWorksheetscalls.
Full disclosure. I'm a contributor and openly biased in favor of it. Code Inspections are just one part of RD.
Always turn on Option Explicit. You can have it automatically by going to Tools -> Options in the VBE and checking the Require Variable Declaration option. This way if you have any variables not defined, the compiler will let you know.
Current "variables" undeclared - wsdem,wspti, DEM_NAME, PTI_NAME, cell, cell_match, i
When you don't define your variable, VBA will declare it as a Variant type that can hold any type of data. While this may be more flexible, it adds processing time to your macro as VBA decides or tests for the type. Additionally, since a Variant can be any type of data, you may miss out on valuable troubleshooting information on Type Mismatch
Something to help with all that worksheet variable stuff - Worksheets have a CodeName property - View Properties window (F4) and the (Name) field (the one at the top) can be used as the worksheet name. This way you can avoid Sheets("mySheet") and instead just use mySheet.
You don't need to Call subs, it's obsolete. Instead just use Sub argument, argument
Integers - integers are obsolete. According to msdn VBA silently converts all integers to long.
Standard VBA naming conventions have camelCase for local variables and PascalCase for other variables and names.
So Dim Wrong as String would be wrong. Additionally, something like target_range wouldn't use the underscore.
Private Function Header_Verification() As Boolean
I'm not sure how this works, you aren't passing any parameters to the function, but it's returning a boolean. So I can call it from anywhere and it will only test the same thing. Even if it's obvious, a function should take a parameter, even if you just pass the sheets to it.
Sub performance_Opt(TurnOn As Boolean)
You're passing this ByRef. VBA implicitly sends arguments ByRef unless you tell it ByVal. So even if it's supposed to be ByRef, put that in there to avoid confusion. But, most the time you can use ByVal.
Be sure to avoid things like .Select - it just slows the code down by needing to fiddle with the spreadsheet while doing everything else behind the scenes. There's a good question on StackOverflow addressing this. This goes for all that copying and pasting as well as filtering. You can do all of that on the data itself rather than the sheets. For instance with copy_data -
Private Sub copy_data() Call copy_paste(DEM_WS, "E4", "A2") Call copy_paste(DEM_WS, "F4", "B2") ... Call copy_paste(DEM_WS, "R4", "DV2") End Sub
What I would suggest is to create some arrays, like this -
Const DEM_CELLS_FROM As String = "E4, F4, G4, BL4, BJ4, BH4, BE4, BF4, BI4, J4, AO4, BP4, BT4, BV4, BO4, BS4, BU4, BN4, BR4, AN4, H4, H4, M4, K4, AM4, AL4, T4, R4, R4, T4, Q4, L4, R4"
Const DEM_CELLS_TO As String = "A2, B2, C2, V2, AC2, AE2, AH2, AK2, AN2, FK2, FN2, EX2, EY2, EZ2, DZ2, EA2, EB2, EH2, EI2, DB2, AW2, DN2, DY2, BK2, CY2, DC2, BE2, DO2, CL2, FI2, FJ2, FS2, DV2"
Dim demSource As Variant
Dim demTarget As Variant
demSource = Split(DEM_CELLS_FROM, ",")
demTarget = Split(DEM_CELLS_TO, ",")
Now you can pull the data into source, change it, populate target and spit it back. Or, if you're not changing anything, a simple loop would work
With wsdem
For i = LBound(demSource) To UBound(demSource)
.Range(demTarget(i)) = .Range(demSource(i))
Next
End With
This doesn't affect the speed (as in make it faster), but it looks cleaner. Either way you could use the loop to do the copy_paste if you didn't change anything else.
This applies to most of your other subs as well. However, what I would do is some variation of this -
Dim lastRow As Long
Dim lastColumn As Long
lastRow = wsdem.Range(wsdem.Rows.Count, 1).End(xlUp).Row
lastColumn = wsdem.Range(1, wsdem.Columns.Count).End(xlUp).Column
Dim demData As Variant
demData = wsdem.Range(wsdem.Cells(1, 1), wsdem.Cells(lastRow, lastColumn))
So now all the data is in an array. Do that for each sheet. Then you can do your matching in the arrays instead of on the sheet -
Dim hiddenRows() As Long
Dim i As Long
For i = LBound(firstarray) To UBound(firstarray)
For j = LBound(secondarray) To UBound(secondarray)
If firstarray(i) = secondarray(j) Then
ReDim Preserve hiddenRows(UBound(hiddenRows) + 1)
hiddenRows(UBound(hiddenRows)) = j 'or whatever
skipnext
End If
Next
skipnext:
Next
Now you can just get the rows numbers when you need them and hide them later. Or you create it as an index to not test in your arrays. It's not a 1:1 example of your data, but the concept is the same - the less you do on the sheet the faster it will be.
Your Header_Verification sub, well I see what you're doing. This is an example of using arrays for storing addresses and strings, comparing them and using another array for the details e.g.
Const DEM_RANGE1 As String = "AL3, AM3, AN3"
Const PTI_RANGE1 As String = "BQ1, BR1, BS1, BT1, BU1, BV1"
Const DEM_HEADERS1 As String = "CSC Account Number , Last Name , First Name , Loan Date , APR , Amt Financed , Number of Payments , Freq"
Const PTI_HEADERS1 As String = "Cus Address , City, State, Zip Code, Phone, Phone"
Const DEM_RANGE2 As String = "AL3, AM3, AN3"
Const DEM_HEADERS2 As String = "Vehicle Year , Make , Model"
Const DEM_RANGE3 As String = "AO3, BE3, BF3, BG3, BH3, BI3, BJ3, BK3, BL3, BM3, BN3, BO3, BP3, BQ3, BR3, BS3, BT3, BV3"
Const DEM_HEADERS3 As String = "Vin , Co- buyer First Name, Co Buyer Last Name, CoBuyer Address, Co Buyer City, Co Buyer State, Co Buyer Zip, Co Buyer Social, Co Buyer DOB, Schedule 1 PMT Freq, Schedule 1 Number of PMT's, Schedule 1 PMT Amount, Schedule 1 PMT Start Date, Schedule 2 PMT Freq, Schedule 2 Number of PMT's, Schedule 2 PMT Amount, Schedule 2 PMT Start Date, Schedule 3 PMT Start Date"
Const PTI_RANGE2 As String = "CD1, CF1, CG1"
Const PTI_HEADERS2 As String = "Employer Phone, Social Security #, Date of Birth"
Then split them into arrays
Dim demCells As String
demCells = Split(DEM_RANGE1, ",")
Dim demHeaders As String
demHeaders = Split(DEM_HEADERS1, ",")
Dim i As Long
For i = LBound(demCells) To UBound(demCells)
If Not wsdem.Range(demCells(i)) = demHeaders(i) Then Debug.Print "Error at " & demHeaders(i)
Next
What you could also do is just use the header array to populate the headers.
So my example don't have you taking the majority of the work off the sheet, but I have given you an idea on how to accomplish that.
wsDEMandwsPTIaren't declared. The call tomatch_hide_recordsdoesn't include quotes aroundDEM_NAMEorPTI_NAME. Insidematch_hide_recordsthe variablecellisn't declared nor iscell_match. Looks likecellis never declared in any of theFor Eachloops. If you can provide code that's compilable withOption ExplicitDebug>Compile without gettingVariable not definedI'll take a look at it again. \$\endgroup\$