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
Are there any code examples left?
New code examples in category VBA
-
VBA 2022-03-27 20:55:02 excel vba check if all substrings in list are in string
-
VBA 2022-03-27 20:40:39 excel vba set cell value to empty
-
VBA 2022-03-27 17:05:52 vba simple quote
-
VBA 2022-03-27 14:30:19 textbox find and replace vb
-
VBA 2022-03-27 09:10:21 nested if else in vb.net
-
VBA 2022-03-27 09:10:09 excel vba string to bits
-
VBA 2022-03-25 02:00:15 vba verticalalignment
-
VBA 2022-03-24 12:20:06 Excel web scraping
-
VBA 2022-03-24 10:11:00 excel vba BitToLong
-
VBA 2022-03-21 18:00:05 excel vba save file txt