VBA 중첩 루프가 작동하지 않습니다.

Question

'inputs'라는 폴더에 파일 그룹이 있습니다. 각 파일에는 정확히 같은 방법으로 배치 된 여러 개의 시트가 들어 있지만 다른 값이 들어 있습니다. 이 파일의 각은 내가 '라는 이름의 한 또 다른 책으로

- 오픈 각 시트의 값 -pull 차례 각 파일이 필요

열 A에있는 모든 시트 이름을 나열하는 요약 시트가 있습니다 consolidator '&이 값을 기반으로 통합 담당자 시트를 계산합니다. - 결과를 복사하여 출력 파일에 붙여넣고 저장하십시오. - 책의 모든 시트와 폴더의 모든 파일에 대해이 작업을 수행해야합니다.

그래서 내 코드에는 (각 시트를 통과하는) 루프가 있고 다른 루프 (각 파일을 통과하는 루프) 내에 있습니다.

문제는 파일의 시트 이름이 같은 경우 (파일 이름이 다른 경우에도) 내 코드가 실행되고 올바른 출력을 생성한다는 것입니다.

그러나 각 파일의 시트 이름이 다르면 내 'file'루프의 두 번째 반복에서 코드가 '파일 이름 y에서 시트 이름 x을 찾을 수 없습니다 (이 경우 파일 이름 y는 첫 번째 반복에서 변경되지 않음).

도움을 주실 수 있으면 미리 감사드립니다. :) 여기

내 코드입니다 :

Sub FileExtractor() 
'SET KEY VARIABLES 

Dim MyPath As String, FilesInPath As String 
Dim MyFiles() As String 
Dim SourceRcount As Long, FNum As Long 
Dim mybook As Workbook, BaseWks As Worksheet 
Dim sourceRange As Range, destrange As Range 
Dim rnum As Long, CalcMode As Long 
Dim MyPathOutput As String 
Dim i As Long 
Dim LastRow As Long 
Dim rngi As Range 
Dim strx As String 
Dim StrLen1 As Integer 
Dim StrLen2 As Integer 


calcsetting = Application.Calculation 


'DEFINE FILE LOCATIONS 
MyPath = ThisWorkbook.Path 
If Right(MyPath, 1) <> "\" Then 
    MyPath = MyPath & "\Inputs\" 
    Else 
    MyPath = MyPath & "Inputs\" 
End If 

' Change this to the path\folder location of your output file. 
MyPathOutput = ThisWorkbook.Path 

' If there are no Excel files in the responses folder, exit. 
FilesInPath = Dir(MyPath & "*.xl*") 
If FilesInPath = "" Then 
    MsgBox "No files found" 
    Exit Sub 
End If 

' Fill the myFiles array with the list of Excel files 
' in the search folder. 
FNum = 0 
Do While FilesInPath <> "" 
    FNum = FNum + 1 
    ReDim Preserve MyFiles(1 To FNum) 
    MyFiles(FNum) = FilesInPath 
    FilesInPath = Dir() 
Loop 

' This sets various application properties. NB. Calculation mode is set to off, so all calculations must be forced 
With Application 
    CalcMode = .Calculation 
    .Calculation = xlCalculationManual 
    .ScreenUpdating = False 
    .EnableEvents = False 
    .DisplayAlerts = False 
End With 

'define the name of the workbook that is running the macro 
Set masterwks = ThisWorkbook 



'BEGIN WORKING THROUGH FILES TO CONSOLIDATE INFO 

'set row number where data will start to be pasted 
cnum = 1 
rnum = 1 

' Loop through all files in the myFiles array. 
If FNum > 0 Then 
    For FNum = LBound(MyFiles) To UBound(MyFiles) 
     Set mybook = Nothing 
     On Error Resume Next 
     Set mybook = Workbooks.Open(MyPath & MyFiles(FNum)) 

     If Not mybook Is Nothing Then 
      On Error Resume Next 

      masterwks.Worksheets("Consolidator").Activate 

      'update consolidator with new input file name 
      newname = "[" & mybook.Name & "]" 

      With masterwks.Worksheets("Consolidator") 
      Currentname = .Range("filename") 
      .Cells.Replace What:=Currentname, Replacement:= _ 
      newname, LookAt:=xlPart, SearchOrder:=xlByColumns, _ 
      MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False 
      End With 

      LastRow = mybook.Sheets("summary").Range("A:A").Find("*", searchdirection:=xlPrevious).Row 


      For i = 4 To LastRow 


       Set rngi = mybook.Sheets("summary").Range("A" & i) 

       StrLen1 = Len(rngi.Value) 
       StrLen2 = StrLen1 - 1 

       strx = Trim(Left(rngi.Value, StrLen2)) 


       newname2 = strx 

       With masterwks.Worksheets("Consolidator") 
       Currentname2 = .Range("sheetname") 
       .Cells.Replace What:=Currentname2, Replacement:= _ 
       newname2, LookAt:=xlPart, SearchOrder:=xlByColumns, _ 
       MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False 
       End With 


       Set sourceRange = masterwks.Sheets("consolidator").Range("outputrange") 
       Calculate 


       'CREATE OUTPUT FILE 
       ' Add a new workbook with one sheet. 
       Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) 
       With BaseWks 
        Sheets(1).Select 
        Cells(1, 1).Select 
       End With 


       'PASTE FILE DATA 
       ' Set the destination range to A 
       Set destrange = BaseWks.Range("A" & rnum) 
       sourceRange.Copy 
       destrange.PasteSpecial Paste:=xlPasteValues, Transpose:=False 
       destrange.PasteSpecial Paste:=xlPasteFormats, Transpose:=False 
       BaseWks.Columns.AutoFit 
       BaseWks.SaveAs Filename:=MyPathOutput & "\" & masterwks.Sheets("consolidator").Range("sheetname") & " - " & mybook.Name 

      Next i 

     End If 

     mybook.Close savechanges:=False 

    Next FNum 
End If 
Application.Calculation = calcsetting 

ExitTheSub: 
' Restore the application properties. 
With Application 
    .ScreenUpdating = True 
    .EnableEvents = True 
    .Calculation = CalcMode 
End With 

    MsgBox "Ta da!!" 


Application.Calculation = calcsetting 
End Sub  

Answer 1

해결책 :

찾을 수 내 문제에 대한 해결책 ...

시트 이름이 작동 교체하기 전에 내 통합 자 시트 파일 이름을 교체 엑셀이 각 개별 셀의 파일 이름을 대체하기 때문에 셀에 이미있는 시트 이름을 찾습니다 (때로는이 주소가 존재하지 않는 경우도 있음).

따라서 파일 이름과 시트 이름을 모두 바꾸기 위해 코드가 변경되어 문제가 해결되었습니다. 모두 감사합니다 :)

Sub FileExtractor() 
'SET KEY VARIABLES 

Dim MyPath As String, FilesInPath As String 
Dim MyFiles() As String 
Dim SourceRcount As Long, FNum As Long 
Dim mybook As Workbook, BaseWks As Worksheet 
Dim sourceRange As Range, destrange As Range 
Dim rnum As Long, CalcMode As Long 
Dim MyPathOutput As String 
Dim StrLen1 As Integer 
Dim StrLen2 As Integer 
Dim ws As Worksheet 
Dim bookname As String 
Dim BaseName As String 



calcsetting = Application.Calculation 
Application.AskToUpdateLinks = False 


'DEFINE FILE LOCATIONS 
MyPath = ThisWorkbook.Path 
If Right(MyPath, 1) <> "\" Then 
    MyPath = MyPath & "\Inputs\" 
    Else 
    MyPath = MyPath & "Inputs\" 
End If 

' Change this to the path\folder location of your output file. 
MyPathOutput = ThisWorkbook.Path 
If Right(MyPathOutput, 1) <> "\" Then 
    MyPathOutput = MyPathOutput & "\Outputs\" 
    Else 
    MyPath = MyPathOutput & "Outputs\" 
End If 


' If there are Excel files in the outputs folder, exit. 
FilesInPath = Dir(MyPathOutput & "*.xl*") 
If FilesInPath <> "" Then 
    MsgBox "There are already files in the output folder." 
    Exit Sub 
End If 

    ' If there are no Excel files in the responses folder, exit. 
FilesInPath = Dir(MyPath & "*.xl*") 
If FilesInPath = "" Then 
    MsgBox "No files found in inputs folder." 
    Exit Sub 
End If 

' Fill the myFiles array with the list of Excel files 
' in the search folder. 
FNum = 0 
Do While FilesInPath <> "" 
    FNum = FNum + 1 
    ReDim Preserve MyFiles(1 To FNum) 
    MyFiles(FNum) = FilesInPath 
    FilesInPath = Dir() 
Loop 

' This sets various application properties. NB. Calculation mode is set to off, so all calculations must be forced 
With Application 
    CalcMode = .Calculation 
    .Calculation = xlCalculationManual 
    .ScreenUpdating = False 
    .EnableEvents = False 
    .DisplayAlerts = False 
End With 

'define the name of the workbook that is running the macro 
Set masterwks = ThisWorkbook 



'BEGIN WORKING THROUGH FILES TO CONSOLIDATE INFO 

'set row number where data will start to be pasted 
cnum = 1 
rnum = 1 

' Loop through all files in the myFiles array. 
If FNum > 0 Then 
    For FNum = LBound(MyFiles) To UBound(MyFiles) 
     Set mybook = Nothing 
     On Error Resume Next 
     Set mybook = Workbooks.Open(MyPath & MyFiles(FNum)) 
      If Not mybook Is Nothing Then 
       On Error Resume Next 

       masterwks.Worksheets("Consolidator").Activate 

       For Each ws In mybook.Worksheets 

        If ws.Name <> "Summary" Then 

         ws.Select 

         'update consolidator with new input file name 
         newname = "[" & mybook.Name & "]" & ws.Name 

         With masterwks.Worksheets("Consolidator") 
         Currentname = .Range("filename") 
         .Cells.Replace What:=Currentname, Replacement:= _ 
         newname, LookAt:=xlPart, SearchOrder:=xlByColumns, _ 
         MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False 
         End With 

         Set sourceRange = masterwks.Sheets("consolidator").Range("outputrange") 
         Calculate 


         'CREATE OUTPUT FILE 
         ' Add a new workbook with one sheet. 
         Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) 

         'PASTE FILE DATA 
         ' Set the destination range to A 
         Set destrange = BaseWks.Range("A" & rnum) 
         sourceRange.Copy 
         destrange.PasteSpecial Paste:=xlPasteValues, Transpose:=False 
         destrange.PasteSpecial Paste:=xlPasteFormats, Transpose:=False 
         BaseWks.Columns.AutoFit 
         bookname = mybook.Name 
         StrLen1 = Len(bookname) 
         StrLen2 = StrLen1 - 5 
         BaseName = Trim(Left(bookname, StrLen2)) 
         BaseWks.SaveAs Filename:=MyPathOutput & "\" & BaseName & " - " & masterwks.Sheets("consolidator").Range("sheetname") & ".xlsx" 
         ActiveWorkbook.Close 

        End If 

       Next ws 

      End If 

     mybook.Close savechanges:=False 

    Next FNum 

End If 

Application.Calculation = calcsetting 

ExitTheSub: 
    ' Restore the application properties. 
    With Application 
     .ScreenUpdating = True 
     .EnableEvents = True 
     .Calculation = CalcMode 
    End With 

    MsgBox "Ta da!!" 


Application.Calculation = calcsetting 
End Sub