Please update CopyColumnToNext macro
Closed this issue · 0 comments
adrielyeung commented
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