Okay. So, let's start with this gigantic array of arrays you've got there. I don't mean to be rude, but what exactly are you doing here?! Each and every one of the inner arrays simply duplicates itself. For the life of me I can't figure out why you have it duplicated. This would work just as well by adding each of these strings to a collection. I would create a single function that intializes and returns this collection.
Private Function GetHeaders() As Collection Dim result As New Collection With result .Add "Account_ID" .Add "Claim_ID" .Add "Account_Name" ' ... End With Set GetHeaders = result End Function And call it at the beginning of Standardization like this.
Dim headers As Collection Set headers = GetHeaders Which turns your loop into this.
Dim header As Variant For Each header In myHeaders Set r = wsImport.Cells.Find(header, , , xlWhole) If Not r Is Nothing Then Set c = wsMain.Cells.Find(header, , , xlWhole) If Not c Is Nothing Then wsImport.Range(r.Offset(1), wsImport.Cells(Rows.Count, r.Column).End(xlUp)).Copy _ wsMain.Cells(Rows.Count, c.Column).End(xlUp)(2) Else msg = msg & vbLf & header & " " & wsMain.Name End If Else msg = msg & vbLf & header & " " & wsImport.Name End If Next Note that I added a level of indentation inside of the loop, and replaced the cryptic e variable with the more sensible and descriptive header variable.
Now the duplication becomes so obvious that it's painful, so let's extract a couple more functions.
Private Function FindHeaderRange(ByVal ws As Worksheet, ByVal header As String) As Range Set FindHeaderRange = ws.Cells.Find(header, , , xlWhole) End Function and
Private Function BuildMessage(ByVal currentMessage As String, ByVal ws As Worksheet, ByVal header As String) As String BuildMessage = currentMessage & vbLf & header & Space(1) & ws.Name End Function Note that I replaced the literal space with a call to Space(1). This is just for readability. It's much easier to parse the function call than a " ".
Also, you never defined msg in your original code. Turn Option Explicit on so this doesn't happen in the future. It helps turn runtime errors into compile time errors. It's kind of magical. You should always be using it.
Anyway, I took the liberty of renaming some more cryptic variables, and now it looks like this.
Dim header As Variant Dim source As Range Dim dest As Range For Each header In headers Set source = FindHeaderRange(wsImport, header) If Not source Is Nothing Then Set dest = FindHeaderRange(wsMain, header) If Not dest Is Nothing Then wsImport.Range(source.Offset(1), wsImport.Cells(Rows.Count, source.Column).End(xlUp)).Copy _ wsMain.Cells(Rows.Count, dest.Column).End(xlUp)(2) Else msg = BuildMessage(msg, wsMain, header) End If Else msg = BuildMessage(msg, wsImport, header) End If Next Which is better, but I'd prefer to take a happy path whenever possible. It's easier to reason about positive statements than double negatives.
For Each header In headers Set source = FindHeaderRange(wsImport, header) If source Is Nothing Then msg = BuildMessage(msg, wsImport, header) Else Set dest = FindHeaderRange(wsMain, header) If dest Is Nothing Then msg = BuildMessage(msg, wsMain, header) Else wsImport.Range(source.Offset(1), wsImport.Cells(Rows.Count, source.Column).End(xlUp)).Copy _ wsMain.Cells(Rows.Count, dest.Column).End(xlUp)(2) End If End If Next - You don't ever use the variable
x. Get rid of it entirely. - You turn screen updating off three times without ever turning it back on. Once is enough.
- Speaking of screen updating, anytime you turn it off, you need an error handler to ensure it always gets turned back on no matter what happens while the code is executing.
- Don't activate and select. Use object references/variables instead.
wsMain.Columns("A:AO").Select Selection.EntireColumn.AutoFit Selection.ClearFormats
Dim tbl As ListObject Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes)
Should be
Dim cols As Range Set cols = wsMain.Columns("AO") cols.EntireColumn.AutoFit cols.ClearFormats Dim tbl As ListObject Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, cols, , xlYes) tbl.TableStyle = "TableStyleMedium9" - Always be explicit about scope. Procedures defined as just plain
Subare public. It's better to write that down instead of relying on a developer's knowledge (or lack there of).
Here's the resulting code. I apologize that I never got around to performance. There were a number of issues to work through first. If I get time, I'll take a look at the performance later.
Public Sub Standardization() On Error GoTo ExitSub Dim headers As Collection Set headers = GetHeaders Dim msg As String Dim wsImport As Worksheet, wsMain As Worksheet Set wsImport = ThisWorkbook.Sheets(2) Set wsMain = ThisWorkbook.Sheets(3) Application.ScreenUpdating = False Dim header As Variant Dim source As Range Dim dest As Range For Each header In headers Set source = FindHeaderRange(wsImport, header) If source Is Nothing Then msg = BuildMessage(msg, wsImport, header) Else Set dest = FindHeaderRange(wsMain, header) If dest Is Nothing Then msg = BuildMessage(msg, wsMain, header) Else wsImport.Range(source.Offset(1), wsImport.Cells(Rows.Count, source.Column).End(xlUp)).Copy _ wsMain.Cells(Rows.Count, dest.Column).End(xlUp)(2) End If End If Next Dim cols As Range Set cols = wsMain.Columns("AO") cols.EntireColumn.AutoFit cols.ClearFormats Dim tbl As ListObject Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, cols, , xlYes) tbl.TableStyle = "TableStyleMedium9" ExitSub: Application.ScreenUpdating = True End Sub