Conditionally copy columns

Your code has tremendously improved since the first time I saw it - good job!

---

This particular line is hard to parse:

wsImport.Range(source.Offset(1), wsImport.Cells(Rows.Count, source.Column).End(xlUp)).Copy _ wsMain.Cells(Rows.Count, dest.Column).End(xlUp)(2) 

Literally: it's crashing the rubberduck parser!

You could introduce a local variable here:

Dim target As Range Set target = wsMain.Cells(Rows.Count, dest.Column).End(xlUp) wsImport.Range(source.Offset(1), wsImport.Cells(Rows.Count, source.Column).End(xlUp)) _ .Copy target(RowIndex:=2) 

Notice how the line continuation is placed so that no instruction is split; rubberduck doesn't care about line continuations, but it's much easier for the human eye to see what function calls return the arguments for which procedure if you don't split an instruction between the name of a procedure and its arguments - vertically lining up .Range and .Copy also make it clearer that .Copy operates on the result of .Range.

---

Dim wsImport As Worksheet, wsMain As Worksheet 

Is this really buying you anything? Multiple declarations on a single line make it harder to locate declarations at a glance. Compare to:

Dim wsImport As Worksheet Dim wsMain As Worksheet 

My eye sees Dim, my brain sees "variable declaration here" - two Dims, two variables. And I read the variable name at pretty much the exact same millisecond as the one I notice the Dim statement, because I don't need to mentally scroll horizontally and locate the comma. Two variables isn't too bad, but more than that would be problematic. Better avoid multiple declarations on a single line.

---

There's a redundant reference to wsMain in this With block:

With wsMain .Columns("A:AO").AutoFit .Cells.ClearFormats .Rows(1).Font.Bold = True .Cells.Font.Name = "Georgia" .Cells.Font.Color = RGB(0, 0, 225) .Cells.Resize(wsMain.Rows.Count - 1).Offset(1).Interior.Color = RGB(216, 228, 188) End With 

See it? Right here:

.Cells.Resize(wsMain.Rows.Count - 1).Offset(1).Interior.Color = RGB(216, 228, 188) 

Could be

.Cells.Resize(.Rows.Count - 1).Offset(1).Interior.Color = RGB(216, 228, 188) 

The extraneous empty lines before End With should be removed, too.

---

Your indentation isn't consistent.

Dim ws As Worksheet For Each ws In Worksheets ws.Select ActiveWindow.Zoom = 85 Next ws 

The only thing that should be at the same indentation level as Public Sub/End Sub, is line labels (which the VBE forces to start at column 1 anyway).

@Mat's Mug made good suggestions (all), but in particular: redundant or implicit references:

Sheets(1).Range("C2", Cells(Rows.Count, "C") 

Try to always be explicit as possible - the above line has one (semi) explicit reference Sheets(1) and 3 implicit ones:

• Rows.Count implies "ActiveSheet.Cells.Rows.Count"
• Cells(Rows.Count, "C") = ActiveSheet.Cells(Rows.Count, "C")
• Sheets(1) should be ThisWorkbook.Worksheets(1)

All explicit:

Sheets(1).Range("C2", Sheets(1).Cells(Sheets(1).Cells.Rows.Count, "C") 

Or

With Sheets(1) .Range("C2", .Cells(.Cells.Rows.Count, "C") End With 

As Mat pointed out: Sheets(1) is as also an implicit reference to ThisWorkbook.Worksheets(1)

So the complete reference is

With ThisWorkbook.Worksheets(1) .Range("C2", .Cells(.Cells.Rows.Count, "C") End With 

A few suggestions that might improve performance:

1. In function FindHeaderRange(), replace the Find method with Match.

   From

   Set FindHeaderRange = ws.Cells.Find(header, , , xlWhole) ... Set source = FindHeaderRange(wsImport, header) If source Is Nothing Then... 

   To

   FindHeaderRange = Application.Match(header, ws.UsedRange.Rows(1), 0) 

   FindHeaderRange()'s return type will change from Range to Variant - Match returns a Double if it finds something and error if not, so checking the result changes to:

   If Not IsError(FindHeaderRange) Then ... 

   (if ok, FindHeaderRange will be 3, 4, 99, etc because we're searching only Row 1)

   Match is significantly faster than Find.

2. In function BuildMessage(): replace Space(1) with " ".

   Space(1) is a function call not worth calling for just one space.

3. Collections (and dictionaries) are great in reducing the amount of code, and retrieving items, but are quite slow at loading data.

   When using the "headers" collection you're not reducing code too much, compared to "headers" as an array; arrays are very fast in both loading and retrieving; more complex code can get convoluted and hard to follow with multidimensional arrays, but in your case a 1-dimensional array would not change the structure: For Each element in Collection = For Each Element in array.

4. Your code is very well organized, modularized, and easy to read - great work! However, there is a price to pay for over-modularizing.

   Function are meant to isolate blocks of code for easier maintenance and to make logical distinction between different functionalities, but calls to functions can get expensive, especially when they're very frequent and have a small number of lines; in-line code is much faster to execute than the extra memory navigation to the function called.

   Your 2 small (and neat) functions FindHeaderRange() and BuildMessage() can be executed directly, without negatively impacting readability.

Another important performance improvement:

The most time consuming line in your For loop:

wsImport.Range(source.Offset(1), wsImport.Cells(Rows.Count, source.Column).End(xlUp)).Copy _ wsMain.Cells(Rows.Count, dest.Column).End(xlUp)(2) 

This is meant to copy and paste the used range part of the current column.

Finding current column used range can be optimized (and explicit):

With wsImport Set fromCol = .Range( source.Offset(1), .Cells(.UsedRange.Rows.Count + 1, source.Column).End(xlUp)) End With With wsMain Set toCol = .Cells(.UsedRange.Rows.Count + 1, dest.Column).End(xlUp)(2) End With fromCol.Copy toCol 

Do you need to dynamically find the used range in wsMain in order to remove previous data?

If so, it would be faster to delete the contents of the entire column:

wsMain.UsedRange.Column(dest.Column).Value2 = vbNullString 

Then, if all columns in wsImport are the same size you can get the last used row before the For loop (just once) and use that value inside the loop.

Edit: tested version of the code:

.

Option Explicit Public Sub projectionTemplateFormat() Dim t1 As Double, t2 As Double xlSpeed True t1 = Timer mainProcess t2 = Timer xlSpeed False MsgBox "Duration: " & t2 - t1 & " seconds" End Sub Private Sub mainProcess() Const SPACE_DELIM As String = " " Dim wsIndex As Worksheet Dim wsImport As Worksheet 'Raw Dim wsFinal As Worksheet Dim importHeaderRng As Range Dim importColRng As Range Dim importHeaderFound As Variant Dim importLastRow As Long Dim finalHeaderRng As Range Dim finalColRng As Range Dim finalHeaderRow As Variant Dim finalHeaderFound As Variant Dim indexHeaderCol As Range Dim header As Variant 'Each item in the FOR loop Dim msg As String Set wsIndex = aIndex 'This is the Code Name; top-left pane: aIndex (Index) Set wsImport = bImport 'Direct reference to Code Name: bImport.Range("A1") Set wsFinal = cFinal 'Reference using Sheets collection: ThisWorkbook.Worksheets("Final") With wsImport.UsedRange Set importHeaderRng = .Rows(1) 'Import - Headers importLastRow = .Rows.Count 'Import - Total Rows End With With wsFinal.UsedRange finalHeaderRow = .Rows(1) 'Final - Headers (as Array) Set finalHeaderRng = .Rows(1) 'Final - Headers (as Range) End With With wsIndex.UsedRange 'Transpose col 3 from Index (without the header), as column names in Import Set indexHeaderCol = .Columns(3).Offset(1, 0).Resize(.Rows.Count - 1, 1) wsImport.Range(wsImport.Cells(1, 1), wsImport.Cells(1, .Rows.Count - 1)).Value2 = Application.Transpose(indexHeaderCol) End With If Len(bImport.Cells(2, 2).Value2) > 0 Then 'if Import sheet is not empty (excluding header row) With Application For Each header In finalHeaderRow 'Loop through all headers in Final If Len(Trim(header)) > 0 Then 'If the Final heade is not empty importHeaderFound = .Match(header, importHeaderRng, 0) 'Find header in Import sheet If IsError(importHeaderFound) Then msg = msg & vbLf & header & SPACE_DELIM & wsImport.Name 'Import doesn't have current header Else finalHeaderFound = .Match(header, finalHeaderRng, 0) 'Find header in Final sheet With wsImport Set importColRng = .UsedRange.Columns(importHeaderFound).Offset(1, 0).Resize(.UsedRange.Rows.Count - 1, 1) End With With wsFinal Set finalColRng = .Range(.Cells(2, finalHeaderFound), .Cells(importLastRow, finalHeaderFound)) finalColRng.Value2 = vbNullString 'Delete previous values (entire column) End With finalColRng.Value2 = importColRng.Value2 'Copy Import data in Final columns End If End If Next header End With allUpper wsFinal 'wsFinal.UsedRange.AutoFilter applyFormat wsFinal.Range(wsFinal.Cells(1, 1), wsFinal.Cells(importLastRow, wsFinal.UsedRange.Columns.Count)) Dim ws As Worksheet For Each ws In Worksheets ws.Activate ActiveWindow.Zoom = 85 ws.Cells(2, 2).Activate ActiveWindow.FreezePanes = True ws.Cells(1, 1).Activate Next Else MsgBox "Missing raw data (Sheet 2 - 'Import')", vbInformation, " Missing Raw Data" End If End Sub Private Sub applyFormat(ByRef rng As Range) With rng .ClearFormats With .Font .Name = "Georgia" .Color = RGB(0, 0, 225) End With .Interior.Color = RGB(216, 228, 188) With .Rows(1) .Font.Bold = True .Interior.ColorIndex = xlAutomatic End With With .Borders .LineStyle = xlDot 'xlContinuous .ColorIndex = xlAutomatic .Weight = xlThin End With End With refit rng End Sub Private Sub allUpper(ByRef sh As Worksheet) Dim arr As Variant, i As Long, j As Long If WorksheetFunction.CountA(sh.UsedRange) > 0 Then arr = sh.UsedRange For i = 2 To UBound(arr, 1) 'each "row" For j = 1 To UBound(arr, 2) 'each "col" arr(i, j) = UCase(RTrim(Replace(arr(i, j), Chr(10), vbNullString))) Next Next sh.UsedRange = arr End If End Sub Public Sub allImportTrim() Dim arr As Variant, i As Long, j As Long, sh As Worksheet Set sh = bImport If WorksheetFunction.CountA(sh.UsedRange) > 0 Then arr = sh.UsedRange For i = 2 To UBound(arr, 1) 'each "row" For j = 1 To UBound(arr, 2) 'each "col" arr(i, j) = RTrim(Replace(arr(i, j), Chr(10), vbNullString)) Next Next sh.UsedRange = arr End If refit sh.UsedRange End Sub Private Sub refit(ByRef rng As Range) With rng .WrapText = False .HorizontalAlignment = xlGeneral .VerticalAlignment = xlCenter .Columns.EntireColumn.AutoFit .Rows.EntireRow.AutoFit End With End Sub