visual basic excel move column header label
'===============================================================================
'>> MoveColumnWithHeader(sHeaderName,sColAsLetter)
'===============================================================================
' Cuts the column according to the cell-value and moves it to the column specified
'
' sHeaderName(String): The header/label of the column to be moved
' sColAsLetter(String): The letter of the column where you want the column to be
'===============================================================================
Sub MoveColumnWithHeader(sHeaderName As String, sColAsLetter As String)
Dim sFunct As String: sFunct = "MoveColumnWithHeader"
Dim bDebugging As Boolean: bDebugging = True
If (bDebugging = True) Then
Debug.Print Format(DateTime.Now, "hh:mm:ss") & " INFO " & sFunct & "| " _
& "Running.. [sHeaderName:" & sHeaderName & "][sColAsLetter:" & sColAsLetter & "]"
End If
'*********************************
' VALIDATIONS and declarations
'*********************************
'(DECLARATIONS)
Dim wbInit As Workbook: Set wbInit = ActiveWorkbook
Dim wsInit As Worksheet: Set wsInit = ActiveSheet
Dim s_rInit As String: s_rInit = Selection.Address
Dim sErrMsg As String
Dim rSrcCell As Range
Dim rSrcCol As Range
Dim rDestCol As Range
Dim bCheckCase As Boolean
Dim iInsertShift As Integer
'On Error GoTo ErrHandling
'(SETTINGS/SETUP) - Part A
Application.ScreenUpdating = False
bCaseIsNB = False
iInsertShift = xlShiftToLeft
Set rSrcCell = wsInit.UsedRange.Find _
(sHeaderName, LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=bCaseIsNB)
'(VALIDATIONS)
'A) Ensure there is only one letter in sColAsLetter
'B) Ensure that there is actually text containing sHeaderName
'--(A)
If (Len(sColAsLetter) <> 1) Then
sErrMsg = sErrMsg & vbNewLine _
& "sColAsLetter of """ & sColAsLetter & """ is not valid. It can only have one letter"
Err.Raise -1
End If
'--(B)
If (rSrcCell Is Nothing) Then
sErrMsg = sErrMsg & vbNewLine _
& "No text found containing the text of """ & sHeaderName & """"
Err.Raise -1
End If
'(SETTINGS/SETUP) - Part B
Set rDestCol = Range(sColAsLetter & "1").EntireColumn
Set rSrcCol = rSrcCell.EntireColumn
If (bDebugging = True) Then
Debug.Print Format(DateTime.Now, "hh:mm:ss") & " INFO " & sFunct & "| " _
& "Source cell with """ & sHeaderName & """ found " _
& "at cell [" & rSrcCol.Address & "]"
End If
'---------------------------------
' WORK
'---------------------------------
'1) Ensure that the destination and source columns aren't the same columns
'2) Cut the column of the header file
'3) Paste the cut column into its destination
'Z) Reactivate the initial workbook/worksheet
'--(1)
If (rSrcCol.EntireColumn.Address = rDestCol.Address) Then
GoTo Sub_Complete
End If
'--(2)
rSrcCol.Cut
'--(3)
rDestCol.Insert Shift:=iInsertShift
Sub_Complete:
Application.CutCopyMode = False
'--(Z)
wbInit.Activate
wsInit.Activate
Range(s_rInit).Select
'-----------v-----------DEBUG INFO-----------v-----------
If (bDebugging = True) Then
Debug.Print Format(DateTime.Now, "hh:mm:ss") & " INFO " & sFunct & "| " _
& "Complete [if not debugging, make bDebugging = false]"
End If
Application.ScreenUpdating = True
Exit Sub
ErrHandling:
Application.ScreenUpdating = True
Debug.Print Format(DateTime.Now, "hh:mm:ss") & " INFO " & sFunct & "| " _
& " -> Failed"
MsgBox _
Title:="Errors in the function: " & sFunct _
, Prompt:=Err.Description _
& vbNewLine & sErrMsg _
, Buttons:=vbCritical
End Sub