VBA Snippets

Wsh_ActiveName

Public Function Wsh_ActiveName() As String
Dim oWsh As Excel.Worksheet
    On Error GoTo ErrorHandler
    'Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)
    
    'Set oWsh = ActiveWindow.SelectedSheets(1)
    Set oWsh = ActiveSheet
    
    Wsh_ActiveName = oWsh.Name
    
    Exit Function
ErrorHandler:
    'Call modMessages.Message_NoWorkbooksOpen(bInformUser)
    Wsh_ActiveName = ""
End Function

Wsh_CopyAfter

Public Sub Wsh_CopyAfter( _
         ByVal sWshNameToCopy As String, _
         ByVal sAfterWshName As String, _
         ByVal sNewWshName As String, _
Optional ByVal sCopyFromWkbName As String = "", _
Optional ByVal sCopyToWbkName As String = "")

Const PROCNAME As String = "Wsh_CopyAfter"

   On Error GoTo ErrorHandler

   Application.DisplayAlerts = False
   If sCopyFromWkbName <> "" Then Workbooks(sCopyFromWkbName).Activate
   Worksheets(sWshNameToCopy).Select                      'selects the sheet to be copied
   If sCopyToWbkName = "" Then
      Worksheets(sWshNameToCopy).Copy after:=Sheets(sAfterWshName)
      Worksheets(sWshNameToCopy & " (2)").Name = sNewWshName           'renames the sheet
   Else
      Worksheets(sWshNameToCopy).Copy after:=Workbooks(sCopyToWbkName).Sheets(sAfterWshName)
      Worksheets(sWshNameToCopy).Name = sNewWshName                    'renames the sheet
   End If
   If sCopyFromWkbName <> "" Then Workbooks(sCopyFromWkbName).Activate
   Application.DisplayAlerts = True
   Exit Sub
ErrorHandler:
'   Call Error_Handle(msMODULENAME, PROCNAME, 2, "WS1", "AD1", _
                         sWshNameToCopy & " and put it after worksheet " & sAfterWshName)
End Sub

Wsh_CopyBefore

Public Sub Wsh_CopyBefore( _
         ByVal sWshNameToCopy As String, _
         ByVal sBeforeWshName As String, _
         ByVal sNewWshName As String, _
Optional ByVal sCopyFromWkbName As String = "", _
Optional ByVal sCopyToWbkName As String = "")
    
Const sPROCNAME As String = "Wsh_CopyBefore"

    On Error GoTo ErrorHandler
    Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)
   
    Application.DisplayAlerts = False
    If sCopyFromWkbName <> "" Then Workbooks(sCopyFromWkbName).Activate
    Worksheets(sWshNameToCopy).Select
    
    If sCopyToWbkName = "" Then
        Worksheets(sWshNameToCopy).Copy Before:=Sheets(sBeforeWshName)
        Worksheets(sWshNameToCopy & " (2)").Name = sNewWshName
    Else
        Worksheets(sWshNameToCopy).Copy Before:=Workbooks(sCopyToWbkName).Sheets(sBeforeWshName)
        Worksheets(sWshNameToCopy).Name = sNewWshName
    End If
    
    Worksheets(sNewWshName).Range("A1").Select
    Worksheets(sNewWshName).Tab.ColorIndex = xlColorIndexNone
    
    If sCopyFromWkbName <> "" Then Workbooks(sCopyFromWkbName).Activate
    Application.DisplayAlerts = True
   
    Exit Sub
ErrorHandler:
    Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Wsh_Delete

Public Sub Wsh_Delete( _
         ByVal sWshName As String, _
Optional ByVal bDisplayAlerts As Boolean = True)

Const sPROCNAME As String = "Wsh_Delete"

Dim objWorkbook As Excel.Workbook
Dim wshname As Worksheet

    On Error GoTo ErrorHandler
    Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)
    
    Application.DisplayAlerts = bDisplayAlerts
    
    Set objWorkbook = Application.ActiveWorkbook
    
    For Each wshname In ActiveWorkbook.Worksheets
        If (wshname.Name = sWshName) Then wshname.Delete
    Next wshname
        
    Application.DisplayAlerts = True

    Exit Sub
ErrorHandler:
    Application.DisplayAlerts = True
    Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Wsh_DeleteAllExcept

Public Sub Wsh_DeleteAllExcept( _
         ByVal sWshNamesToKeep As String, _
Optional ByVal sSeperateChar As String = ";", _
Optional ByVal bDisplayAlerts As Boolean = True, _
Optional ByVal sWbkName As String = "")

Const sPROCNAME As String = "Wsh_DeleteAllExcept"

Dim wshname As Worksheet
Dim bdeletewsh As Boolean
Dim stemporary As String
Dim swshnametokeep As String
Dim sreturnwbkname As String
Dim sreturnwshname As String

   On Error GoTo ErrorHandler

   If sSeperateChar = "" Then sSeperateChar = Chr(10)
   If sWbkName <> "" Then sreturnwbkname = ActiveWorkbook.Name
   If sWbkName <> "" Then Workbooks(sWbkName).Activate
   Application.DisplayAlerts = False
   
   For Each wshname In ActiveWorkbook.Worksheets
      If Wsh_ListIsItIn(wshname.Name, sWshNamesToKeep) = False Then wshname.Delete
   Next wshname
   
   Application.DisplayAlerts = bDisplayAlerts
   If sWbkName <> "" Then 
      Workbooks(sreturnwbkname).Activate
   End If

    Exit Sub
ErrorHandler:
    Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Wsh_DeleteAllNotShaded

Public Sub Wsh_DeleteAllNotShaded( _
Optional ByVal bDisplayAlerts As Boolean = True)

Const sPROCNAME As String = "Wsh_DeleteAllNotShaded"

Dim objWorkbook As Excel.Workbook
Dim wshname As Worksheet

    On Error GoTo ErrorHandler
    Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)

    Application.DisplayAlerts = bDisplayAlerts
    
    Set objWorkbook = Application.ActiveWorkbook
    
    For Each wshname In ActiveWorkbook.Worksheets
        If (wshname.Tab.ColorIndex = xlColorIndexNone) Then wshname.Delete
    Next wshname

    Application.DisplayAlerts = True

    Exit Sub
ErrorHandler:
    Application.DisplayAlerts = True
    Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Wsh_Exists

Public Function Wsh_Exists( _
         ByVal oWbk As Excel.Workbook, _
         ByVal sWshName As String) As Boolean

Dim sName As String

    On Error GoTo ErrorHandler
    
    sName = oWbk.Sheets(sWshName).Name
    
    If Len(sName) > 0 Then Wsh_Exists = True
    Exit Function
ErrorHandler:
    Wsh_Exists = False
End Function

Public Function Wsh_Exists( _
    ByVal oWbk As Excel.Workbook, _
    ByVal sWshName As String) As Boolean
    
Dim bexists As Boolean
Dim lwshcount As Long
Dim owsh As Excel.Worksheet

   On Error GoTo ErrorHandler
        
   bexists = False
   For lwshcount = 1 To oWbk.Worksheets.Count
      Set owsh = oWbk.Worksheets(lwshcount)
      
      If (owsh.Name = sWshName) Then
         bexists = True
         Exit For
      End If
   Next lwshcount
   Wsh_Exists = bexists
    
   Exit Function
ErrorHandler:
   Wsh_Exists = False
End Function

Wsh_Filtering_AutoFilterShowAll

Public Function Wsh_Filtering_AutoFilterShowAll( _
         ByVal sWshName As String) As Boolean

    On Error GoTo ErrorHandler

    Wsh_Filtering_AutoFilterShowAll = True
'    Sheets(sWshName).ShowAllData

    Exit Function
ErrorHandler:
    Wsh_Filtering_AutoFilterShowAll = False
End Function

Wsh_NameIsInList

Public Function Wsh_NameIsInList( _
         ByVal sWshName As String, _
         ByVal sWshConcatenation As String, _
Optional ByVal sSeperateChar As String = ";", _
Optional ByVal sWbkName As String = "") As Boolean

Const sPROCNAME As String = "Wsh_NameIsInList"

Dim swshnametokeep As String
Dim stemporary As String

    On Error GoTo ErrorHandler
    Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)
    
    Wsh_NameIsInList = False
    
    stemporary = sWshConcatenation
    Do While Len(stemporary) > 0
       If InStr(stemporary, sSeperateChar) > -1 Then
          swshnametokeep = Left(stemporary, InStr(stemporary, sSeperateChar))
       Else
          swshnametokeep = stemporary
          stemporary = ""
       End If
    
       If sWshName = swshnametokeep Then
          Wsh_NameIsInList = True
          Exit Function
       End If
       stemporary = Right(stemporary, InStr(stemporary, sSeperateChar) + 1)
    Loop

    Exit Function
ErrorHandler:
    Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function

Wsh_NameToNamedRange

Public Function Wsh_NameToNamedRange( _
         ByVal sWshName As String) As String

Const sPROCNAME As String = "Wsh_NameToNamedRange"

Dim sreturn As String

    On Error GoTo ErrorHandler
    Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)

    sreturn = UCase(sWshName)
    sreturn = Replace(sreturn, " ", "")
    sreturn = Replace(sreturn, "-", "")
    sreturn = Replace(sreturn, "(", "")
    sreturn = Replace(sreturn, ")", "")

    Wsh_NameToNamedRange = sreturn
    Exit Function
ErrorHandler:
    Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function

Wsh_PasteValues

Public Sub Wsh_PasteValues(ByVal sReturnCell As String, _
                           Optional ByVal sWshName As String = "", _
                           Optional ByVal sWbkName As String = "")
Dim sreturnwbkname As String
Dim sreturnwshname As String

   If sWbkName <> "" Then sreturnwbkname = ActiveWorkbook.Name
   If sWshName <> "" Then sreturnwshname = ActiveSheet.Name
   If sWbkName <> "" Then Workbooks(sWbkName).Activate
   If sWshName <> "" Then Worksheets(sWshName).Select
   Cells.Copy
   Cells.PasteSpecial Paste:=xlValues
   Application.CutCopyMode = False
   Range(sReturnCell).Select
   If sWbkName <> "" Then Workbooks(sreturnwbkname).Activate
   If sWshName <> "" Then Worksheets(sreturnwshname).Select
End Sub

Wsh_Protect

Public Sub Wsh_Protect(ByVal sWshName As String)
    Worksheets(sWshName).Protect _
       Contents:=True, _
       AllowFormattingCells:=True
End Sub

Wsh_SelectOne

Public Sub Wsh_SelectOne(ByVal sWshName As String)

Const sProcName As String = "Wsh_SelectOne"

Dim isheetcount As Integer

    On Error GoTo ErrorHandler
    For isheetcount = 1 To ActiveWorkbook.Worksheets.Count
        If (ActiveWorkbook.Worksheets(isheetcount).Name = sWshName) Then
            ActiveWorkbook.Worksheets(isheetcount).Activate
            Exit Sub
        End If
    Next isheetcount
    
    Exit Sub
ErrorHandler:
    Call Error_Handle(msMODULENAME, sProcName, Err.Number, Err.Description)
End Sub

Wsh_UnProtect

Public Sub Wsh_UnProtect(ByVal sWshName As String)
    Worksheets(sWshName).Unprotect
End Sub