여러 통합 문서의 데이터를 여러 워크 시트와 요약 통합 문서로 결합

Question

여러 통합 문서 (단 하나의 시트 만 포함)의 데이터를 요약 통합 문서로 결합하는 코드가 있습니다. 여러 워크 시트가있는 여러 통합 문서에서 코드를 변경하기 위해 코드로 고민하고 있지만 할 수는 없습니다. 도와 주시겠습니까?

Sub MergeAllWorkbooks() 

Dim myPath As String, FilesInPath As String, lastrow As String 
Dim MyFiles() As String 
Dim SourceRcount As Long, Fnum As Long 
Dim mybook As Workbook, BaseWks As Worksheet, mysht As Worksheet 
Dim sourceRange As Range, destRange As Range 
Dim rnum As Long, CalcMode As Long 
Dim i As Integer, j As Integer 


'Fill in the path\folder where the files are 
myPath = ThisWorkbook.Path & "\Some" 

'Add a slash at the end if the user forget it 
If Right(myPath, 1) <> "\" Then 
    myPath = myPath & "\" 
End If 

'If there are no Excel files in the folder exit the sub 
FilesInPath = dir(myPath & "*.xl*") 
If FilesInPath = "" Then 
    MsgBox "No files found" 
    Exit Sub 
End If 

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

'Change ScreenUpdating, Calculation and EnableEvents 
With Application 
    CalcMode = .Calculation 
    .Calculation = xlCalculationManual 
    .ScreenUpdating = False 
    .EnableEvents = False 
End With 


Set BaseWks = ThisWorkbook.Worksheets(3) 
rnum = 1 

'Loop through all files in the array(myFiles) 
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)) 
     Set mysht = mybook.Worksheet 

     On Error GoTo 0 

     If Not mybook Is Nothing Then 

      On Error Resume Next 




      'For i = 1 To Worksheets(i).Count 
      'LastRow = Worksheets(i).Range("F" & rows.Count).End(xlUp).Row 
      'MsgBox LastRow 

      With mybook.Worksheets(1) 
       Set sourceRange = Range("A6:I100") ' & LastRow) 
      End With 




       If Err.Number > 0 Then 
        Err.Clear 
        Set sourceRange = Nothing 
       Else 
        'if SourceRange use all columns then skip this file 
        If sourceRange.Columns.Count >= BaseWks.Columns.Count Then 
         Set sourceRange = Nothing 
        End If 
       End If 

       On Error GoTo 0 

       If Not sourceRange Is Nothing Then 

        SourceRcount = sourceRange.rows.Count 

        If rnum + SourceRcount >= BaseWks.rows.Count Then 
         MsgBox "Sorry there are not enough rows in the sheet" 
         BaseWks.Columns.AutoFit 
         mybook.Close SaveChanges:=False 
         GoTo ExitTheSub 
        Else 

         'Copy the file name in column A 
         'For j = 1 To Worksheets(j).Count 'Worksheets.Count 
          With sourceRange 
           BaseWks.Cells(rnum, "A"). _ 
             Resize(.rows.Count).Value = Range("A2").Value 'MyFiles(Fnum) 
          End With 

         'Next j 


         'Set the destrange 
         Set destRange = BaseWks.Range("B" & rnum) 

         'we copy the values from the sourceRange to the destrange 
         With sourceRange 
          Set destRange = destRange. _ 
              Resize(.rows.Count, .Columns.Count) 
         End With 
         destRange.Value = sourceRange.Value 

         rnum = rnum + SourceRcount 




        End If 

       End If 

      'Next i 

      mybook.Close SaveChanges:=False 
     End If 

    Next Fnum 
    BaseWks.Columns.AutoFit 
End If 



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

Answer 1

Tim이 친절하게 지적한 점은 도움이 필요한 부분이 명확하지 않습니다. 그러나 아래에 포함 된 코드는 쿠키 커터베이스를 제공해야합니다. 나는 그것을 테스트했고, 잘 작동하는 것 같다. 선택한 통합 문서의 범위와 포함 된 모든 시트를 반복합니다.

나는이 지저분한 코드

P.S 죄송합니다 도움이되기를 바랍니다 - 나는 그것을 정리하는 시간이 없습니다.

Sub MergeMultiple1() 

Dim sh As Excel.Worksheet 
Dim DestSh As Worksheet 
Dim Last As Long 
Dim shLast As Long 
Dim CopyRng As Range 
Dim StartRow As Long 

With Application 
    .ScreenUpdating = False 
    .EnableEvents = False 
End With 

' Delete the summary sheet if it exists. 
Application.DisplayAlerts = False 
On Error Resume Next 
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete 
On Error GoTo 0 
Application.DisplayAlerts = True 
' Add a new summary worksheet. 
Set DestSh = ActiveWorkbook.Worksheets.Add 
DestSh.Name = "RDBMergeSheet" 
' Fill in the start row. 

currentfiles = selectedfiles() 

For nfile = LBound(currentfiles) To UBound(currentfiles) 
    Set oFS = CreateObject("scripting.filesystemobject") 
    Filename = currentfiles(nfile) 
    Set workbk1 = Workbooks.Open(Filename) 
    StartRow = 1 
' Loop through all worksheets and copy the data to the 
    For Each sh In ActiveWorkbook.Worksheets 
'Set sh = ActiveWorkbook.Worksheets(1) 
     If sh.Name <> DestSh.Name Then 
      ' Find the last row with data on the summary 
      ' and source worksheets. 
      Last = LastRow(DestSh) 
      shLast = LastRow(sh) 
      ' If source worksheet is not empty and if the last 
      ' row >= StartRow, copy the range. 

      If shLast > 0 And shLast >= StartRow Then 
       'Set the range that you want to copy 
       Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast)) 
       ' Test to see whether there are enough rows in the summary 
       ' worksheet to copy all the data. 

       If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then 
        MsgBox "There are not enough rows in the " & _ 
        "summary worksheet to place the data." 
        GoTo ExitTheSub 
       End If 

       ' This statement copies values and formats. 
       CopyRng.Copy 
       rnga = DestSh.Cells(Last + 1, "A") 

      With DestSh.Cells(Last + 1, "A") 
      .PasteSpecial xlPasteValues 
      .PasteSpecial xlPasteFormats 
      Application.CutCopyMode = False 
      End With 

      DestSh.Cells(Last + 1, "X").Value = workbk1.Name 

     End If 

    End If 

Next 
workbk1.Close 
Next 
ExitTheSub: 

Application.GoTo DestSh.Cells(1) 

DestSh.Columns.AutoFit 

With Application 
.ScreenUpdating = True 
.EnableEvents = True 
End With 

End Function 

Function LastRow(sh As Worksheet) 
On Error Resume Next 
LastRow = sh.Cells.Find(What:="*", _ 
After:=sh.Range("A1"), _ 
Lookat:=xlPart, _ 
LookIn:=xlFormulas, _ 
SearchOrder:=xlByRows, _ 
SearchDirection:=xlPrevious, _ 
MatchCase:=False).Row 
On Error GoTo 0 
End Function 

Function LastCol(sh As Worksheet) 
On Error Resume Next 
LastCol = sh.Cells.Find(What:="*", _ 
After:=sh.Range("A1"), _ 
Lookat:=xlPart, _ 
LookIn:=xlFormulas, _ 
SearchOrder:=xlByColumns, _ 
SearchDirection:=xlPrevious, _ 
MatchCase:=False).Column 
On Error GoTo 0 
End Function 

Function selectedfiles() 
selectedfiles = Application.GetOpenFilename(_ 
filefilter:="Speadsheets, *.xl*; *.csv", MultiSelect:=True) 

End Function 

Answer 2

여러 워크 시트에서 요약을하고자하지만 통합 문서는 당신이 자신의 코드가 사용자의 요구에 맞게 만들 수있는 방법을 상세하게 설명이 procedure을 확인하는 것이 좋습니다합니다.

대부분의 경우 코드를 수정하도록 누군가에게 요청하면 디버그하거나 나중에 수정할 수 없습니다.