Answers for "vba move column based on header"

vba move column header

'===============================================================================
'>> MoveColumnWithSpecifiedHeader(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 MoveColumnWithSpecifiedHeader(sHeaderName As String, sColAsLetter As String)

    Dim sFunct As String: sFunct = "MoveColumnWithSpecifiedHeader"

    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