Personal Toolbox
* Wrap Headers [ApplyFormatWrappedHeaders_To_ActiveSheet]
* Last Row / Last Column [GetLastCell]
* Set Column Object based on Header [CheckHeader]
* Insert Tab (Rename) [InsertTabRename]
* Delimited Strings: Remove Dupes [DupeRemovalDelimited]
* Strings - Type (Blank/Numeric/Alpha/Mixed) [IdentifyStringType]
* Format (Standard) [FormatStandard]
[ApplyFormatWrappedHeaders_To_ActiveSheet]
Sub ApplyFormatWrappedHeaders_To_ActiveSheet()
FormatWrappedHeaders (ActiveSheet.Index)
MsgBox "Finished Reformatting with Wrapped Headers"
End Sub
FormatWrappedHeaders (ActiveSheet.Index)
MsgBox "Finished Reformatting with Wrapped Headers"
End Sub
[GetLastCell]
Function GetLastCell(myWs As Long) As String
Dim iRe1 As Long, iCe1 As Long, iLoop As Long, iTempR As Long, iTempC As Long
iRe1 = 0: iCe1 = 0
iTempC = 0
For iLoop = 1 To 300
iTempC = Worksheets(myWs).Cells(iLoop, Columns.Count).End(xlToLeft).Column
If iTempC > iCe1 Then
iCe1 = iTempC
iTempR = Worksheets(myWs).Cells(Rows.Count, iCe1).End(xlUp).Row
If iTempR > iRe1 Then iRe1 = iTempR
End If
Next iLoop
iTempR = 0
For iLoop = 1 To 300
iTempR = Worksheets(myWs).Cells(Rows.Count, iLoop).End(xlUp).Row
If iTempR > iRe1 Then
iRe1 = iTempR
iTempC = Worksheets(myWs).Cells(iRe1, Columns.Count).End(xlToLeft).Column
If iTempC > iCe1 Then iCe1 = iTempC
End If
Next iLoop
If iRe1 = 0 Then iRe1 = 1
If iCe1 = 0 Then iCe1 = 1
GetLastCell = Cells(iRe1, iCe1).Address
End Function
Dim iRe1 As Long, iCe1 As Long, iLoop As Long, iTempR As Long, iTempC As Long
iRe1 = 0: iCe1 = 0
iTempC = 0
For iLoop = 1 To 300
iTempC = Worksheets(myWs).Cells(iLoop, Columns.Count).End(xlToLeft).Column
If iTempC > iCe1 Then
iCe1 = iTempC
iTempR = Worksheets(myWs).Cells(Rows.Count, iCe1).End(xlUp).Row
If iTempR > iRe1 Then iRe1 = iTempR
End If
Next iLoop
iTempR = 0
For iLoop = 1 To 300
iTempR = Worksheets(myWs).Cells(Rows.Count, iLoop).End(xlUp).Row
If iTempR > iRe1 Then
iRe1 = iTempR
iTempC = Worksheets(myWs).Cells(iRe1, Columns.Count).End(xlToLeft).Column
If iTempC > iCe1 Then iCe1 = iTempC
End If
Next iLoop
If iRe1 = 0 Then iRe1 = 1
If iCe1 = 0 Then iCe1 = 1
GetLastCell = Cells(iRe1, iCe1).Address
End Function
[CheckHeader]
Public Function CheckHeader(iMyText As String, iMyWs As Long, iMyRow As Long, iMyEndCol As Long) As Double
'----------------------------------------------------------------------------------------------------
'Defines Current Sheet then moves to desired sheet
'Loops through the columns in the defined Header Row checking for an exact match on defined String
'Returns a numeric value if String is found, 0 if not found.
'Selects the original tab that was active when Function was called
'----------------------------------------------------------------------------------------------------
'Example:(How to use function)
'If CheckHeader(Ws1, iHeader, iCe1, "Stripped") <> 0 Then iStripA = CheckHeader(Ws1, iHeader, iCe1, "Stripped")
'----------------------------------------------------------------------------------------------------
Dim iTempWorksheet As Long
iTempWorksheet = ActiveWorkbook.ActiveSheet.Index
Worksheets(iMyWs).Select
Dim iLoopCol As Long
CheckHeader = 0
For iLoopCol = 1 To iMyEndCol
If UCase(Cells(iMyRow, iLoopCol)) = UCase(iMyText) Then
CheckHeader = iLoopCol
Exit For
Else
End If
Next iLoopCol
Worksheets(iTempWorksheet).Select
End Function
'----------------------------------------------------------------------------------------------------
'Defines Current Sheet then moves to desired sheet
'Loops through the columns in the defined Header Row checking for an exact match on defined String
'Returns a numeric value if String is found, 0 if not found.
'Selects the original tab that was active when Function was called
'----------------------------------------------------------------------------------------------------
'Example:(How to use function)
'If CheckHeader(Ws1, iHeader, iCe1, "Stripped") <> 0 Then iStripA = CheckHeader(Ws1, iHeader, iCe1, "Stripped")
'----------------------------------------------------------------------------------------------------
Dim iTempWorksheet As Long
iTempWorksheet = ActiveWorkbook.ActiveSheet.Index
Worksheets(iMyWs).Select
Dim iLoopCol As Long
CheckHeader = 0
For iLoopCol = 1 To iMyEndCol
If UCase(Cells(iMyRow, iLoopCol)) = UCase(iMyText) Then
CheckHeader = iLoopCol
Exit For
Else
End If
Next iLoopCol
Worksheets(iTempWorksheet).Select
End Function
[InsertTabRename]
Public Function InsertTabRename(myNewName As String)
'----------------------------------------------------------------------------------------------------------
'Defines current tab
'Loops through all tabs in book, if a tab exists with the same name as the desired new tab, it deletes it.
'Adds a new tab to the end of the book, renames it using desired String(myNewName)
'Selects the original tab that was active when Function was called
'----------------------------------------------------------------------------------------------------------
Dim iCurrentWs As Long, iTabLoop As Long, sCurrentWs As String
If ActiveSheet.Name = myNewName Then Worksheets(1).Select
iCurrentWs = ActiveSheet.Index: sCurrentWs = ActiveSheet.Name
For iTabLoop = 1 To ActiveWorkbook.Worksheets.Count
If Worksheets(iTabLoop).Name = myNewName Then
Application.DisplayAlerts = False
Worksheets(iTabLoop).Delete
Application.DisplayAlerts = True
Worksheets(sCurrentWs).Select
Exit For
End If
Next iTabLoop
'-------------------------------------------------------------------------
'add new sheet: rename
Sheets.Add after:=Worksheets(ActiveWorkbook.Worksheets.Count)
ActiveSheet.Name = myNewName
'-------------------------------------------------------------------------
Worksheets(sCurrentWs).Select
End Function
'----------------------------------------------------------------------------------------------------------
'Defines current tab
'Loops through all tabs in book, if a tab exists with the same name as the desired new tab, it deletes it.
'Adds a new tab to the end of the book, renames it using desired String(myNewName)
'Selects the original tab that was active when Function was called
'----------------------------------------------------------------------------------------------------------
Dim iCurrentWs As Long, iTabLoop As Long, sCurrentWs As String
If ActiveSheet.Name = myNewName Then Worksheets(1).Select
iCurrentWs = ActiveSheet.Index: sCurrentWs = ActiveSheet.Name
For iTabLoop = 1 To ActiveWorkbook.Worksheets.Count
If Worksheets(iTabLoop).Name = myNewName Then
Application.DisplayAlerts = False
Worksheets(iTabLoop).Delete
Application.DisplayAlerts = True
Worksheets(sCurrentWs).Select
Exit For
End If
Next iTabLoop
'-------------------------------------------------------------------------
'add new sheet: rename
Sheets.Add after:=Worksheets(ActiveWorkbook.Worksheets.Count)
ActiveSheet.Name = myNewName
'-------------------------------------------------------------------------
Worksheets(sCurrentWs).Select
End Function
[DupeRemovalDelimited]
Function DupeRemovalDelimited(myInputStr As Variant, myDelimiter As Variant) As String
Dim sTemp As String, sDelimiter As String, sAssembled As String
Dim aSplitMe As Variant, iLoop As Long
sTemp = myInputStr
sDelimiter = myDelimiter
sAssembled = ""
If sTemp = "" Then GoTo gNoDelimiterSkipReturnOriginalValue
If InStr(1, sTemp, sDelimiter, vbTextCompare) = 0 Then GoTo gNoDelimiterSkipReturnOriginalValue
'SSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSS
'Split String (Populate Public Array: Row1-Headers)
aSplitMe = Split(sTemp, sDelimiter)
'Load All non blank values into the Array (Header Position)
For iLoop = LBound(aSplitMe) To UBound(aSplitMe)
If InStr(1, sAssembled, aSplitMe(iLoop) & sDelimiter, vbTextCompare) > 0 Then GoTo gSkipLoopValueAlreadyExists
sAssembled = sAssembled & LCase(aSplitMe(iLoop)) & sDelimiter
'If aSplitMe(iLoop) <> "" Then 'aHeaderDump(1, iLoop + 1) = aSplitMe(iLoop)
gSkipLoopValueAlreadyExists:
Next iLoop
GoTo gReturnFinalResult
'SSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSS
gNoDelimiterSkipReturnOriginalValue:
sAssembled = sTemp
GoTo gReturnFinalResult
gReturnFinalResult:
If Right(sAssembled, 1) = sDelimiter Then sAssembled = Left(sAssembled, Len(sAssembled) - 1)
DupeRemovalDelimited = sAssembled
End Function
Dim sTemp As String, sDelimiter As String, sAssembled As String
Dim aSplitMe As Variant, iLoop As Long
sTemp = myInputStr
sDelimiter = myDelimiter
sAssembled = ""
If sTemp = "" Then GoTo gNoDelimiterSkipReturnOriginalValue
If InStr(1, sTemp, sDelimiter, vbTextCompare) = 0 Then GoTo gNoDelimiterSkipReturnOriginalValue
'SSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSS
'Split String (Populate Public Array: Row1-Headers)
aSplitMe = Split(sTemp, sDelimiter)
'Load All non blank values into the Array (Header Position)
For iLoop = LBound(aSplitMe) To UBound(aSplitMe)
If InStr(1, sAssembled, aSplitMe(iLoop) & sDelimiter, vbTextCompare) > 0 Then GoTo gSkipLoopValueAlreadyExists
sAssembled = sAssembled & LCase(aSplitMe(iLoop)) & sDelimiter
'If aSplitMe(iLoop) <> "" Then 'aHeaderDump(1, iLoop + 1) = aSplitMe(iLoop)
gSkipLoopValueAlreadyExists:
Next iLoop
GoTo gReturnFinalResult
'SSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSS
gNoDelimiterSkipReturnOriginalValue:
sAssembled = sTemp
GoTo gReturnFinalResult
gReturnFinalResult:
If Right(sAssembled, 1) = sDelimiter Then sAssembled = Left(sAssembled, Len(sAssembled) - 1)
DupeRemovalDelimited = sAssembled
End Function
[IdentifyStringType]
Function IdentifyStringType(vMyInput As Variant) As String
Dim iLoop As Long, iLenPre As Long, iLenPost As Long, sTemp As String
'Load the string and take a snapshot of the length
sTemp = vMyInput
iLenPre = Len(sTemp)
'Skip the review process for 0 length strings
If iLenPre = 0 Then GoTo gNoString
'Loop through all 10 digits and remove them from the string
For iLoop = 0 To 9
sTemp = Replace(sTemp, iLoop, "", , , vbTextCompare)
Next iLoop
'Take a snapshot of the length AFTER replacement of numeric values
iLenPost = Len(sTemp)
'Mark "Numeric" if there are no Alpha Characters
If iLenPost = 0 Then GoTo gAllNumbers
'Mark "Alpha" if there are no Numeric Characters
If iLenPre = iLenPost Then GoTo gAllAlpha
'If it gets this far, the string is a mix of ALPHA + NUMERIC
GoTo gMixed
'------------------------------------------------------------------------
gNoString:
IdentifyStringType = "Blank"
Exit Function
'------------------------------------------------------------------------
gAllNumbers:
IdentifyStringType = "Numeric"
Exit Function
'------------------------------------------------------------------------
gAllAlpha:
IdentifyStringType = "Alpha"
Exit Function
'------------------------------------------------------------------------
gMixed:
IdentifyStringType = "Mixed"
Exit Function
'------------------------------------------------------------------------
End Function
Dim iLoop As Long, iLenPre As Long, iLenPost As Long, sTemp As String
'Load the string and take a snapshot of the length
sTemp = vMyInput
iLenPre = Len(sTemp)
'Skip the review process for 0 length strings
If iLenPre = 0 Then GoTo gNoString
'Loop through all 10 digits and remove them from the string
For iLoop = 0 To 9
sTemp = Replace(sTemp, iLoop, "", , , vbTextCompare)
Next iLoop
'Take a snapshot of the length AFTER replacement of numeric values
iLenPost = Len(sTemp)
'Mark "Numeric" if there are no Alpha Characters
If iLenPost = 0 Then GoTo gAllNumbers
'Mark "Alpha" if there are no Numeric Characters
If iLenPre = iLenPost Then GoTo gAllAlpha
'If it gets this far, the string is a mix of ALPHA + NUMERIC
GoTo gMixed
'------------------------------------------------------------------------
gNoString:
IdentifyStringType = "Blank"
Exit Function
'------------------------------------------------------------------------
gAllNumbers:
IdentifyStringType = "Numeric"
Exit Function
'------------------------------------------------------------------------
gAllAlpha:
IdentifyStringType = "Alpha"
Exit Function
'------------------------------------------------------------------------
gMixed:
IdentifyStringType = "Mixed"
Exit Function
'------------------------------------------------------------------------
End Function
[FormatStandard]
Public Function FormatStandard(myTab As Long)
'-----------------------------------------------------------------------------------------
'Selects desired worksheet, applys formats and returns to current worksheet when finished
'Formatting Standards: Lock Headers, Apply Filters, Autofit, Remove WrapText
'-----------------------------------------------------------------------------------------
Dim iCurrentWs As Long
iCurrentWs = ActiveSheet.Index
'-------------------------------------------------------------------------
'Freeze Header, Fix Header Fields
Sheets(myTab).Select
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
Application.CutCopyMode = False
Cells.Select
Selection.AutoFilter
'-------------------------------------------------------------------------
'Autofit columns
Cells.Select
Cells.EntireColumn.AutoFit
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A2").Select
'-------------------------------------------------------------------------
Worksheets(iCurrentWs).Select
End Function
'-----------------------------------------------------------------------------------------
'Selects desired worksheet, applys formats and returns to current worksheet when finished
'Formatting Standards: Lock Headers, Apply Filters, Autofit, Remove WrapText
'-----------------------------------------------------------------------------------------
Dim iCurrentWs As Long
iCurrentWs = ActiveSheet.Index
'-------------------------------------------------------------------------
'Freeze Header, Fix Header Fields
Sheets(myTab).Select
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
Application.CutCopyMode = False
Cells.Select
Selection.AutoFilter
'-------------------------------------------------------------------------
'Autofit columns
Cells.Select
Cells.EntireColumn.AutoFit
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A2").Select
'-------------------------------------------------------------------------
Worksheets(iCurrentWs).Select
End Function
