VBA Code to Check if Sheet Exists and Archive It

[OilEconomist]

Thanks in advance for any suggestions and I will provide feedback.

I would like to check if "SheetA" exists and if so archive it to where "SheetA" will be come "SheetA.01" and if both "SheetA" and "SheetA.01" exists make it "SheetA.02", etc. Sheet A will be located between "Start.SheetA" and "End.SheetA" I would like the order to becomes as follows whenever I re-run.

Start.SheetA
SheetA
SheetA.01
SheetA.02
SheetA.03
etc.
End.SheetA

SheetA may never exist initially, but as I keep running the macro for the assignment, it will exist and I will continue to archive "SheetA"

Thanks!

 

[Yongle]

Ensure that SheetA AND Start.SheetA exist before running the code
- the VBA deals with any sheet name without requiring modification
- spaces can be used the name of SheetA but the other 2 must consistent
- so if sheet to be archived is named "A & C", then "Start.A & C" and "End.A & C" (End sheet is not used in the code)

The code can deal with sheets 01 to 99. If expecting to exceed 100 then
- amend the code to format as "000"
- and From s = 1 To 99 should be amended to From s = 1 To 999

Test in a COPY of your workbook
- run from sheet to be archived

Place both procedures in the same module

Sub ArchiveActiveSheet()
    Dim Archived As Worksheet, PrevSheet As Worksheet, NewSheet As Worksheet, wb As Workbook
    Dim sName As String, tName As String, s As Long
    Set wb = ThisWorkbook
    Set Archived = ActiveSheet
    sName = Archived.Name
    Set PrevSheet = Sheets("Start." & sName)
[I][COLOR=#006400]'archive sheet[/COLOR][/I]
    Set NewSheet = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
    Archived.UsedRange.Copy
    With NewSheet.Range("A1")
        .PasteSpecial (xlPasteFormats)
        .PasteSpecial (xlPasteValues)
        .PasteSpecial (xlPasteColumnWidths)
    End With
[COLOR=#006400][I]'get previous sheet[/I][/COLOR]
    For s = 1 To 99
        tName = sName & "." & Format(s, "00")
        If SheetExists(tName) Then Set PrevSheet = Sheets(tName) Else Exit For
    Next
[COLOR=#006400][I]'rename, move etc[/I][/COLOR]
    With NewSheet
        .Name = tName
        .Move After:=PrevSheet
    End With
    Archived.Activate
End Sub

Private Function SheetExists(shName As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Sheets(shName).Name
    If Err.Number = 9 Then SheetExists = False Else SheetExists = True
    On Error GoTo 0
End Function

 

[Yongle]

an afterthought...

To avoid code failing if accidentally run from an archived sheet etc
replace line 6

    Set PrevSheet = Sheets("Start." & sName)

with

    If SheetExists("Start." & sName) Then
        Set PrevSheet = Sheets("Start." & sName)
    Else
        MsgBox "Sheet Start." & sName & " is missing", vbCritical
        Exit Sub
    End If

 

[Yongle]

Reading your post again, I may have misinterpreted which sheet is the active sheet which must be archived
- is the current sheet to be archived SheetA itself (my assumption) or the latest archived version of SheetA

 

[OilEconomist]

Thanks for your response and apologies for the confusion. I got a little lost in the logic as I'm still new to VBA Coding.


-First Check is "SheetA" exists anywhere in the workbook and if it does, archive it between the following Tabs:
"Start.Archive" and "End.Archive" and name it "SheetA.01"
-If "SheetA.01" already exists, make SheetA" into "SheetA.02" right after "SheetA.01 and so on.

The next parts are probably a bit more tricky and i've changed things a bit.
-I would like to then do the same thing for "SheetB" and "SheetC"

If they exist, put "SheetB" as "SheetB.01" after the last "SheetA.XX" and if "SheetB.01" exists, make a "SheetB.02" after "SheetB.01" and so on.

Now do the same with "SheetC"

Remember I'm new to VBA, so the simpler the better.

Thanks for your support and hard work.

 

[Yongle]

VBA below checks the entire workbook and looks for the sheets listsed in constant Shts
If any of those sheets exist they are RE-POSITIONED and RENAMED
"Archive" interpreted as MOVE (not COPY) - is this your requirement?

The code
Delete the previous code
Paste the whole of the VBA below into an EMPTY standard module

Option Explicit
Private Const Shts = "SheetA,SheetB,SheetC,SheetD,SheetE,SheetF"
Private PrevSheet As Worksheet
Sub MoveSheets()
    Dim Sh As Variant, Ws As Worksheet
    Set PrevSheet = Sheets("Start.Archive")
    For Each Sh In Split(Shts, ",")
        For Each Ws In ThisWorkbook.Sheets
            If SheetExists(Sh) Then Call MoveAndName(Sh)
            Next Ws
    Next Sh
End Sub
Private Function SheetExists(ByVal shName As String) As Boolean
    Dim Ws As Worksheet
    On Error Resume Next
    Set Ws = Sheets(shName).Name
    If Err.Number = 9 Then SheetExists = False Else SheetExists = True
    On Error GoTo 0
End Function
Private Sub MoveAndName(ByVal sName As String)
    Dim s As Integer, testName As String
    For s = 1 To 99
        testName = sName & "." & Format(s, "00")
        If SheetExists(testName) Then Set PrevSheet = Sheets(testName) Else Exit For
    Next
    With Sheets(sName)
        .Name = testName
        .Move After:=PrevSheet
    End With
    Set PrevSheet = Sheets(testName)
End Sub

Adapting to your needs
Ensure that sheet Start.Archive exists before running the procedure
If SheetA, SheetB etc are not the names you are using, then amend constant Shts accordingly
- list sheets as a single string with a comma between each one
- do NOT include any spaces other than those that are in valid sheet names
The VBA handles sheet numbers between 1 and 99

 

[OilEconomist]

Sorry for the late response Yongle. I am going to test it and I will get back with you!

This looks great and I'm excited to test it, I just need time to adjust my sheet.