adrielyeung/macro-workbook

Please update CopyColumnToNext macro

Closed this issue · 0 comments

Sub CopyColumnToNext()
'
' CopyColumnToNext Macro
' Copy the content of rightmost filled non-coloured column to the next,
' increasing the header by 1 if it is a number/date.
'
' Option to select:
' 1) Number of times to copy
' 2) If copy > 1 times, copy header only except last time
' (Useful for skipping through a few days, e.g. weekend)
'
' Keyboard Shortcut: Ctrl+k
'
    Dim LastColInd As Integer, CopyTimes As Variant
    Dim CopyHeaderOnly As String
    Dim i As Long, j As Long
    
    LastColInd = ActiveSheet.UsedRange.Columns.Count
    
    Do While True
        CopyTimes = InputBox("Please enter number of times you want to copy the last column for:", _
            "Copy Times", "1")
        If IsNumeric(CopyTimes) Then
            Exit Do
        End If
        If MsgBox("Please enter a number.", vbOKCancel, "Number required") = vbCancel Then Exit Sub
    Loop
    
    If CInt(CopyTimes) > 1 Then
        CopyHeaderOnly = MsgBox("Copy header only except last time?", vbQuestion + vbYesNo, "Copy header only")
    Else
        CopyHeaderOnly = vbYes
    End If
    
    For j = 1 To ActiveSheet.UsedRange.Rows.Count
        ' Check for cells with white colour
        If Cells(j, LastColInd).EntireRow.Hidden = False And Cells(j, LastColInd).Interior.Color = 16777215 Then
            While Len(Trim(Cells(j, LastColInd).Value)) = 0 And LastColInd > 0
                LastColInd = LastColInd - 1
            Wend
            
            Exit For
        End If
    Next j
    
    For i = 1 To CInt(CopyTimes)
        ' Start a new column
        LastColInd = LastColInd + 1
        
        ' Increment header by 1 if not written
        If Len(Trim(Cells(1, LastColInd).Value)) = 0 Then
            Cells(1, LastColInd).Value = Cells(1, LastColInd - 1).Value + 1
        End If
        
        ' Copy remaining rows
        If CopyHeaderOnly = vbNo Or i = CInt(CopyTimes) Then
            For j = 2 To ActiveSheet.UsedRange.Rows.Count
                If Cells(j, LastColInd).EntireRow.Hidden = False And Cells(j, LastColInd).Interior.Color = 16777215 Then
                    Cells(j, LastColInd).Value = Cells(j, LastColInd - i).Value
                End If
            Next j
        End If
        
        ActiveSheet.Columns(LastColInd).AutoFit
    Next i
    
    ActiveWorkbook.Save
End Sub