CODEWITHSUNDEEP
vbaloops
Ashely
Ashely

Reputation: 23

DIR loop with specific sheet names

I have 5 files in a folder. I need to split a sheet called Marrs Upload into a separate worksheet.

I've managed to get it to work for the first file but after that it comes up with the "Run Time error: 9 Subscript out of range" message.

Here is my current code:

Sub Hello()

StrFile = Application.ActiveWorkbook.Path + "\" 'Get path name
GetFullFile = ActiveWorkbook.Name 'File name
sFilename = Left(GetFullFile, (InStr(GetFullFile, ".") - 1)) 'Fine the . and
i = 1 'Part of the name counter
ExportFile = StrFile + "Import to Marrs\"
SaveAsFileName = "Marrs Upload " & Format(Date, "dd-mm-yyyy ") ' Saves the filename Marrs Upload (Date) followed by counter
Application.DisplayAlerts = False
strFilename = Dir(StrFile)

If Len(strFilename) = 0 Then Exit Sub ' exit if no files in folder
Do Until strFilename = ""
        Sheets("Marrs Upload").Move ' Moves Marrs Upload tab
        ActiveWorkbook.Close (False)
        ActiveWorkbook.SaveAs (ExportFile & SaveAsFileName & i)
        'ActiveWorkbook.Close (False)
        'ActiveWorkbook.Close (False)
        i = i + 1
        strFilename = Dir()


Loop
End Sub

I've tried most things and cannot get any further.

Kind Regards, Ashley

I've added to original code to only work if a certain sheet name exists.

Sub Hello()



StrFile = Application.ActiveWorkbook.Path + "\" 'Get path name
GetFullFile = ActiveWorkbook.Name 'File name
sFileName = Left(GetFullFile, (InStr(GetFullFile, ".") - 1)) 'Find the . and returns only file name minus extension
i = 1 'Counter
ExportFile = StrFile + "Import to Marrs\" 'Saves new worksheet in a specific folder
SaveAsFileName = "Marrs Upload " & Format(Date, "dd-mm-yyyy ") ' Saves the filename Marrs Upload (Date) followed by counter
Application.DisplayAlerts = False 'Don't display alerts "Overwrite, ect"



StrFileName = Dir(StrFile) 'No extension as can be a combination of .xlsm and .xls

Do While Len(StrFileName) > 0 'Loop when files are in DIR
    If CheckSheet("Marrs Upload") Then 'if workseet contains a tab called "Marrs Upload" then continue.
            Sheets("Marrs Upload").Move ' Moves Marrs Upload tab
            ActiveWorkbook.SaveAs (ExportFile & SaveAsFileName & i) 'Save worksheet as Marrs Upload (Date) (Counter)
            ActiveWorkbook.Close (False) 'Don't need to save original file (Audit Trail)
            i = i + 1 'Increase counter by 1
    End If
StrFileName = Dir() 'used when worksheet doesn't contain sheet called "Marrs Upload"
Loop

End Sub

Function CheckSheet(ByVal sSheetName As String) As Boolean

Dim oSheet As Worksheet
Dim bReturn As Boolean

For Each oSheet In ActiveWorkbook.Sheets

    If oSheet.Name = sSheetName Then

        bReturn = True
        Exit For

    End If

Next oSheet

CheckSheet = bReturn

End Function

Kind Regards, Ashley

Upvotes: 1

Views: 388

Answers (1)

Tim Williams
Tim Williams

Reputation: 166895

EDIT: Tested, and works for me.

Sub Hello()

Dim SourceFolder As String, DestFolder As String
Dim f As String, SaveAsFileName As String, sFileName As String
Dim i As Long, wb As Workbook

    '*** if ActiveWorkbook has the macro, safer to use ThisWorkbook
    SourceFolder = Application.ActiveWorkbook.Path + "\"
    DestFolder = SourceFolder & "Import to Marrs\"

    '*** what are you doing with this?
    sFileName = Left(ActiveWorkbook.Name, _
                     (InStr(ActiveWorkbook.Name, ".") - 1))

    ' Saves the filename Marrs Upload (Date) followed by counter
    SaveAsFileName = "Marrs Upload " & Format(Date, "dd-mm-yyyy ")

    Application.DisplayAlerts = False

    i = 1 'Part of the name counter
    f = Dir(SourceFolder & "*.xls*") '*** use wildcard for XL files only

    Do While Len(f) > 0

        Debug.Print f

        Set wb = Workbooks.Open(SourceFolder & f)

        If CheckSheet(wb, "Marrs Upload") Then
            wb.Sheets("Marrs Upload").Move ' Moves Marrs Upload tab
            '*** the wb with the moved sheet is now active: save it
            With ActiveWorkbook
            .SaveAs (DestFolder & SaveAsFileName & i)
            .Close True
            End With
            i = i + 1
        End If
        wb.Close False '***close the one we just opened. Not saving?
        f = Dir() '*** next file
    Loop

End Sub


Function CheckSheet(wb as WorkBook, ByVal sSheetName As String) As Boolean

    Dim oSheet As Worksheet
    Dim bReturn As Boolean

    For Each oSheet In wb.WorkSheets
        If oSheet.Name = sSheetName Then
            bReturn = True
            Exit For
        End If
    Next oSheet

    CheckSheet = bReturn

End Function

Upvotes: 1

Related Questions