excel - copy columns.vba

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