특정 시트 이름을 가진 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