Skip to content

Instantly share code, notes, and snippets.

@davestewart
Last active March 26, 2024 13:25
Show Gist options
  • Save davestewart/8301538c48a09162e868665ec67d6f3a to your computer and use it in GitHub Desktop.
Save davestewart/8301538c48a09162e868665ec67d6f3a to your computer and use it in GitHub Desktop.
Type Region
src As Range
col As Long
End Type
Sub Copy_Columns()
'
' This Excel macro copies columns from a <source> sheet to a <target> sheet:
'
' - by default, sheets 1 and 2 will be used as <source> and <target>
' - if named sheets "bank" and "breakdown" are defined, these will be used as <source> and <target> instead
' - the columns in <target> determine which columns from <source> will be copied
' - if a "Date" column is present in both sheets, then the latest <target> date will be used to filter later <source> columns
' - if no "Date" column then cells from only the selected cell in <source> will be copied
'
' Note that after running:
'
' - a message box will confirm the copy entries and sheets
' - the cells to be copied are selected as a preview
' - you can optionally set the sheet to auto-save before copying (as Macros cannot be undone)
'
' ------------------------------------------------------------------------------------------
' preferences (modify these if required)
srcName = "bank"
trgName = "breakdown"
dateName = "Date"
autoSave = False
' ------------------------------------------------------------------------------------------
' get sheets
On Error Resume Next
Dim srcSheet As Worksheet
Set srcSheet = Sheets(srcName)
If srcSheet Is Nothing Then
Set srcSheet = Sheets(1)
End If
Dim trgSheet As Worksheet
Set trgSheet = Sheets(trgName)
If trgSheet Is Nothing Then
Set trgSheet = Sheets(2)
If trgSheet Is Nothing Then
Exit Sub
End If
End If
On Error GoTo 0
' ------------------------------------------------------------------------------------------
' prepare data
' source
srcSheet.Activate
Dim srcRowEnd As Long
srcRowEnd = srcSheet.Cells(srcSheet.Rows.Count, 1).End(xlUp).Row
Dim srcRowStart As Long
srcRowStart = ActiveCell.Row
Dim srcSelection As Range
' target
Dim trgHeaders As Range
Set trgHeaders = trgSheet.Range("A1", trgSheet.Cells(1, trgSheet.Columns.Count).End(xlToLeft))
Dim trgRowStart As Long
trgRowStart = trgSheet.Cells(trgSheet.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
' active cell is out of range
If srcRowStart > srcRowEnd Then
srcRowStart = srcRowEnd
End If
' no rows in trg sheet
If trgRowStart = 2 Then
srcRowStart = 2
End If
' check for date columns to automatically determine starting row
Dim trgDate As Range
Set trgDate = Find_Column(trgSheet.Cells, dateName)
' if the target sheet has a date column
If Not trgDate Is Nothing Then
Dim lastDate As Range
Set lastDate = trgSheet.Cells(trgSheet.Rows.Count, trgDate.Column).End(xlUp)
If IsDate(lastDate) Then
Dim srcDate As Range
Set srcDate = Find_Column(srcSheet.Cells, dateName)
' if the source sheet has a date column
If Not srcDate Is Nothing Then
' get the last cell in column
Dim srcDateEnd As Range
Set srcDateEnd = srcSheet.Columns(srcDate.Column).Cells(Rows.Count, 1).End(xlUp)
' determine whether to copy from the next date, or possibly duplicate current date entries
numSrcDates = Application.WorksheetFunction.CountIf(srcSheet.Columns(srcDate.Column), lastDate)
numTrgDates = Application.WorksheetFunction.CountIf(trgSheet.Columns(trgDate.Column), lastDate)
hasMissingEntries = numSrcDates > 0 And numSrcDates <> numTrgDates
' warn about missing entries
If hasMissingEntries Then
confirm = MsgBox("There is a mismatch between entries for " & lastDate & " so you will need to review and reconcile duplicates." & vbNewLine & vbNewLine & "Do you want to continue?", vbYesNo)
If confirm = vbNo Then Exit Sub
End If
' find the row of the current / next date
Dim dateRow As Long
dateRow = Find_Date_Row(Range(srcDate, srcDateEnd), lastDate.value, Not hasMissingEntries)
' if we find the date then update the starting row
If dateRow > 0 Then
srcRowStart = dateRow
ElseIf dateRow < 0 Then
MsgBox "No data to update"
Exit Sub
End If
End If
End If
End If
' ------------------------------------------------------------------------------------------
' process data
Dim srcIndex As Long
Dim srcRng As Range
Dim trgHeader As Range
Dim regions() As Region
ReDim regions(1 To trgHeaders.Cells.Count)
' for each target header
For Each trgHeader In trgHeaders
' find the corresponding source header
Dim srcHeader As Range
Set srcHeader = Find_Column(srcSheet.Cells, trgHeader)
' if we have a source header
If Not srcHeader Is Nothing Then
' set the range from the start row to the end row
Set srcRng = Range( _
Cells(srcRowStart, srcHeader.Column), _
Cells(srcRowEnd, srcHeader.Column) _
)
' prepare the copy
srcIndex = srcIndex + 1
Set regions(srcIndex).src = srcRng
regions(srcIndex).col = trgHeader.Column
' update source selection
If srcSelection Is Nothing Then
Set srcSelection = srcRng
Else
Set srcSelection = Union(srcSelection, srcRng)
End If
End If
Next
' ------------------------------------------------------------------------------------------
' take action
' define final number of entries
Dim numEntries As Long
numEntries = srcRowEnd - srcRowStart + 1
' select source cells
srcSelection.Select
' confirm save
confirm = MsgBox("Copy " & numEntries & " entries(s) from """ & srcSheet.Name & """ to """ & trgSheet.Name & """ ? ", vbYesNo)
If confirm = vbNo Then Exit Sub
' save worksheet
If autoSave And Not ActiveWorkbook Is Nothing Then
ActiveWorkbook.Save
End If
' insert rows
trgSheet.Select
Rows(trgRowStart & ":" & trgRowStart + numEntries - 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
' copy cells
Dim i As Long
For i = LBound(regions, 1) To UBound(regions, 1)
If Not regions(i).src Is Nothing Then
regions(i).src.Copy ' Destination:=regions(i).trg
trgSheet.Cells(trgRowStart, regions(i).col).PasteSpecial (xlPasteValues)
End If
Next i
' select new target cells
Cells(trgRowStart, 1).Select
Selection.Resize(numEntries, srcIndex).Select
' autofit if target is empty
If trgRowStart = 2 Then
Columns.AutoFit
End If
End Sub
Function Find_Column(rng As Range, value As Variant) As Range
Dim found As Range
Set found = rng.Cells.Find(value, , xlValues, xlWhole, 1, 1, 0)
If Not found Is Nothing Then
Set Find_Column = found
End If
End Function
Function Find_Date_Row(r As Range, d As Date, Optional after As Boolean = False) As Long
Dim cell As Range
FindRowOfDate = 0
For Each cell In r
If IsDate(cell.value) Then
If after Then
If cell.value > d Then
Find_Date_Row = cell.Row
Exit Function
End If
Else
If cell.value = d Then
Find_Date_Row = cell.Row
Exit Function
End If
End If
End If
Next cell
Find_Date_Row = -1
End Function
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment