VBA Snippets

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_DeleteAllExcept

Public Sub Wsh_DeleteAllExcept(sWshNamesToKeep As String, _
                               Optional sSeperateChar As String = ";", _
                               Optional bDisplayAlerts As Boolean = True, _
                               Optional sWbkName As String = "")
Dim wshname As Worksheet
Dim bdeletewsh As Boolean
Dim stemporary As String
Dim swshnametokeep As String
Dim sreturnwbkname As String
Dim sreturnwshname As String

   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
End Sub

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