使用特定工作表名稱的DIR循環

Question

我在一個文件夾中有5個文件。我需要將名爲Marrs Upload的工作表分成單獨的工作表。

我已經設法讓它爲第一個文件工作，但之後它出現了「運行時間錯誤：9下標超出範圍」的消息。

這裏是我當前的代碼：

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