CODEWITHSUNDEEP
excelvbaxlsm
kris oey
kris oey

Reputation: 1

VBA for Deleting Sheets & Save As Based on Column Values

I need help with VBA for deleting sheets that do not have certain characters (based on cell values in a column A) and do not equal to sheet name "IWF Extract", and then saving them based on those cell values as well.

Hoping that i can loop through all of the cell values within the column A

Thank you in advance

enter image description here

I have this for save as loop

 Sub SaveAsLoop()
 Dim wkb As Workbook
 Dim mp As String, fp As String, mfn As String, en As String, strName As String
 Dim cRng As Range, c As Range
 Dim ws As Worksheet

 Set cRng = Sheets("ORG").Range("A2:A" & Sheets("ORG").Range("A" & Rows.Count).End(xlUp).Row)
 mp = "C:\Users\oey\Documents\Kris Oey\04 JAN FY24\"
 fp = "C:\Users\oey\Documents\Kris Oey\FY24\"
 mfn = "IWF - "
 en = ".xlsm"
 ws
 Set wkb = Workbooks.Open(mp & "\Projects_WA_Summary_FY24 (TEST).xlsm")
 
 For Each c In cRng
    strName = c.Value
    wkb.SaveCopyAs (fp & mfn & strName & en)

    
 Next c
End Sub

Upvotes: 0

Views: 69

Answers (1)

taller
taller

Reputation: 18762

  • Iterate through all worksheets, maintaining a list of relevant sheets in an array (arrSht).
  • Duplicate (copy) the relevant sheets to form a new workbook.
  • Save the newly created workbook with the desired name.
Option Explicit

Sub SplitWorkbook()
    Dim inWB As Workbook, outWB As Workbook
    Dim i As Long, Sht As Worksheet, arrSht
    Dim cRng As Range, c As Range
    Const IWF_SHT = "IWF Extract"
    Const ORG_SHT = "ORG"
    Const SRC_FILE = "Projects_WA_Summary_FY24 (TEST).xlsm"
    Const DES_FILE = "IWF - @.xlsm"
    Const SRC_DIR = "C:\Users\oey\Documents\Kris Oey\04 JAN FY24\"
    Const DES_DIR = "C:\Users\oey\Documents\Kris Oey\FY24\"
    
    ' If the code is in SRC_FILE, and SRC_FILE is opened
    ' Set inWB = ThisWorkbook ' OR Set inWB = ActiveWorkbook
    ' Open SRC_FILE
    Set inWB = Workbooks.Open(SRC_DIR & SRC_FILE)
    With inWB.Sheets("ORG")
        Set cRng = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
    End With
    For Each c In cRng.Cells
        ReDim arrSht(1 To inWB.Worksheets.Count)
        arrSht(1) = IWF_SHT
        i = 1
        For Each Sht In inWB.Worksheets
            If InStr(1, Sht.Name, c.Value, vbTextCompare) > 0 Then
                i = i + 1
                arrSht(i) = Sht.Name
            End If
        Next Sht
        ReDim Preserve arrSht(1 To i)
        inWB.Sheets(arrSht).Copy
        ActiveWorkbook.SaveAs Filename:=DES_DIR & _
            Replace(DES_FILE, "@", c.Value), _
            FileFormat:=xlOpenXMLWorkbookMacroEnabled
        ActiveWorkbook.Close False
    Next
    ' inWB.Close False
End Sub

Microsoft documentation:

InStr function

StrComp function

Workbook.SaveAs method (Excel)

Upvotes: 1

Related Questions