Question

我在一个文件夹中有5个文件。我需要将名为Marrs Upload的工作表拆分为单独的工作表。

我设法让它为第一个文件工作但在此之后它出现了＆＃34;运行时错误：9下标超出范围＆＃34;消息。

这是我目前的代码：

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

我已经尝试过大多数事情而且无法继续下去。

亲切的问候，阿什利

我已添加到原始代码，仅在存在特定工作表名称时才能使用。

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

亲切的问候，阿什利

Answer 1

编辑：经过测试，适合我。

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

具有特定工作表名称的DIR循环

1 个答案: