다른 Excel 통합 문서에서 데이터 병합

먼저 코딩을 할 때 나는 초보자이지만 내 데이터를 파헤치는 데 어떻게 도움이되는지 알려주고 있습니다.다른 Excel 통합 문서에서 데이터 병합

현재 팀 구성원의 시간 기록표 데이터를 캡처하여 마스터 요약 통합 문서에 복사하는 방법을 모색 중입니다.

매크로를 기록한 다음 코드 정리를 위해 약간의 작업을 다시 수행했습니다. 하지만 지금은 내 매크로를 실행할 때 런타임 오류 '9': 아래 첨자 범위를 얻을. 다음과 같이

내 코드는 다음과 같습니다

Option Explicit 

Sub MergeAll() 

' Open all Timesheets 

Workbooks.Open Filename:= _ 
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_JAMAL.xlsx" 
Workbooks.Open Filename:= _ 
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_LOKESH.xlsx" 
Workbooks.Open Filename:= _ 
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_NONI.xlsx" 
Workbooks.Open Filename:= _ 
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_RAJESH.xlsx" 
Workbooks.Open Filename:= _ 
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_SANTHOSH.xlsx" 
Workbooks.Open Filename:= _ 
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_7.xlsx" 
Workbooks.Open Filename:= _ 
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_8.xlsx" 
Workbooks.Open Filename:= _ 
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_9.xlsx" 

' Activate and Copy Data 

Windows("2016_JAMAL.xlsx").Activate 
Range("G2:J2").Select 
Selection.Copy 
Windows("master.xlsm").Activate 
Range("C2:F2").Select 
ActiveSheet.Paste 

Windows("2016_LOKESH.xlsx").Activate 
Range("G2:J2").Select 
Selection.Copy 
Windows("master.xlsm").Activate 
Range("C2:F2").Select 
ActiveSheet.Paste 

Windows("2016_NONI.xlsx").Activate 
Range("G2:J2").Select 
Selection.Copy 
Windows("master.xlsm").Activate 
Range("C2:F2").Select 
ActiveSheet.Paste 

Windows("2016_RAJESH.xlsx").Activate 
Range("G2:J2").Select 
Selection.Copy 
Windows("master.xlsm").Activate 
Range("C2:F2").Select 
ActiveSheet.Paste 

Windows("2016_SANTHOSH.xlsx").Activate 
Range("G2:J2").Select 
Selection.Copy 
Windows("master.xlsm").Activate 
Range("C2:F2").Select 
ActiveSheet.Paste 

Windows("2016_WARREN.xlsx").Activate 
Range("G2:J2").Select 
Selection.Copy 
Windows("master.xlsm").Activate 
Range("C2:F2").Select 
ActiveSheet.Paste 

Windows("2016_7.xlsx").Activate 
Range("G2:J2").Select 
Selection.Copy 
Windows("master.xlsm").Activate 
Range("C2:F2").Select 
ActiveSheet.Paste 

Windows("2016_8.xlsx").Activate 
Range("G2:J2").Select 
Selection.Copy 
Windows("master.xlsm").Activate 
Range("C2:F2").Select 
ActiveSheet.Paste 

Windows("2016_9.xlsx").Activate 
Range("G2:J2").Select 
Selection.Copy 
Windows("master.xlsm").Activate 
Range("C2:F2").Select 
ActiveSheet.Paste 

' Close all Timesheets 

Windows("2016_JAMAL.xlsx").Activate 
ActiveWindow.Close 

Windows("2016_LOKESH.xlsx").Activate 
ActiveWindow.Close 

Windows("2016_NONI.xlsx").Activate 
ActiveWindow.Close 

Windows("2016_RAJESH.xlsx").Activate 
ActiveWindow.Close 

Windows("2016_SANTHOSH.xlsx").Activate 
ActiveWindow.Close 

Windows("2016_WARREN.xlsx").Activate 
ActiveWindow.Close 

Windows("2016_7.xlsx").Activate 
ActiveWindow.Close 

Windows("2016_8.xlsx").Activate 
ActiveWindow.Close 

Windows("2016_9.xlsx").Activate 
ActiveWindow.Close 

End Sub

가 지금은 윈도우 후, 각 라인에 나오는 한 일부 코드를했다 ("파일 이름") 라인을 활성화합니다.. 이것은이었다

나는 이것이 내가 올바른 위치까지 스크롤과에 따라하는 것은 각각의 시간을 절약하기 전에 활성 셀했다 경우에만 것을 생각으로

ActiveWindow.SmallScroll Down:=-18

이 변경됩니다.

나는 아이디어가 없으며 도움을 많이 주시면 감사하겠습니다.

기록을 위해 지금까지 튜브 튜토리얼 비디오를 따라 사이트에서 코드를 복사하고 붙여 넣는 것을 포함하여 여러 가지 다른 방법을 시도했지만 각 시간과 각 방법마다 동일한 오류가 발생합니다. 사전에

감사합니다,

리치

UPDATE

내가 매크로를 기록 재 단순히 내가 기록하는 동안 한 일의 순서를 변경

. 더 이상 오류가 발생하지 않습니다. 그러나 코드는 매우 지저분하고 오래갑니다. 이 과정에서 화면이 너무 많이 깜박입니다. 사용자에게보다 부드러운 환경을 제공 할 수있는 방법이 있습니까? 새로운 코드는 지금까지 도움을 UPDATE

Sub MergeAll2() 
' 
' MergeAll2 Macro 
' 

' 
' Open All 

Workbooks.Open Filename:= _ 
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_7.xlsx" 
Workbooks.Open Filename:= _ 
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_8.xlsx" 
Workbooks.Open Filename:= _ 
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_9.xlsx" 
Workbooks.Open Filename:= _ 
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_JAMAL.xlsx" 
Workbooks.Open Filename:= _ 
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_LOKESH.xlsx" 
Workbooks.Open Filename:= _ 
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_NONI.xlsx" 
Workbooks.Open Filename:= _ 
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_RAJESH.xlsx" 
Workbooks.Open Filename:= _ 
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_SANTHOSH.xlsx" 
Workbooks.Open Filename:= _ 
    "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_WARREN.xlsx" 

' Copy & Paste 

Windows("2016_JAMAL.xlsx").Activate 
Range("G2:J2").Select 
Selection.Copy 
Windows("master.xlsm").Activate 
Range("C2").Select 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
    :=False, Transpose:=False 
Windows("2016_LOKESH.xlsx").Activate 
Range("G2:J2").Select 
Application.CutCopyMode = False 
Selection.Copy 
Windows("master.xlsm").Activate 
Range("C3:F3").Select 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
    :=False, Transpose:=False 
Windows("2016_NONI.xlsx").Activate 
Range("G2:J2").Select 
Application.CutCopyMode = False 
Selection.Copy 
Windows("master.xlsm").Activate 
Range("C4").Select 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
    :=False, Transpose:=False 
Windows("2016_RAJESH.xlsx").Activate 
Range("G2:J2").Select 
Application.CutCopyMode = False 
Selection.Copy 
Windows("master.xlsm").Activate 
Range("C5").Select 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
    :=False, Transpose:=False 
Windows("2016_SANTHOSH.xlsx").Activate 
Range("G2:J2").Select 
Application.CutCopyMode = False 
Selection.Copy 
Windows("master.xlsm").Activate 
Range("C6").Select 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
    :=False, Transpose:=False 
Windows("2016_WARREN.xlsx").Activate 
Range("G2:J2").Select 
Application.CutCopyMode = False 
Selection.Copy 
Windows("master.xlsm").Activate 
Range("C7").Select 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
    :=False, Transpose:=False 
Windows("2016_7.xlsx").Activate 
Range("G2:J2").Select 
Application.CutCopyMode = False 
Selection.Copy 
Windows("master.xlsm").Activate 
Range("C8").Select 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
    :=False, Transpose:=False 
Windows("2016_8.xlsx").Activate 
Range("G2:J2").Select 
Application.CutCopyMode = False 
Selection.Copy 
Windows("master.xlsm").Activate 
Range("C9").Select 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
    :=False, Transpose:=False 
Windows("2016_9.xlsx").Activate 
Range("G2:J2").Select 
Application.CutCopyMode = False 
Selection.Copy 
Windows("master.xlsm").Activate 
Range("C10").Select 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
    :=False, Transpose:=False 

' Close All 

Windows("2016_JAMAL.xlsx").Activate 
ActiveWindow.Close 
Windows("2016_LOKESH.xlsx").Activate 
ActiveWindow.Close 
Windows("2016_NONI.xlsx").Activate 
ActiveWindow.Close 
Windows("2016_RAJESH.xlsx").Activate 
ActiveWindow.Close 
Windows("2016_SANTHOSH.xlsx").Activate 
ActiveWindow.Close 
Windows("2016_WARREN.xlsx").Activate 
ActiveWindow.Close 
Windows("2016_7.xlsx").Activate 
ActiveWindow.Close 
Windows("2016_8.xlsx").Activate 
ActiveWindow.Close 
Windows("2016_9.xlsx").Activate 
ActiveWindow.Close 
End Sub

아래 2

많은 감사합니다. 나는 또한에서 복사하기 "2016_JAMAL"에있는 시트에 기록하고 "마스터"에있는 시트를 선택할 수 있도록

Workbooks("master").ActiveSheet.Range("C2:F2").Value = Workbooks("2016_JAMAL").ActiveSheet.Range("G2:J2").Value

:이 행을 편집 찾고 있어요.

둘째,이 시트의 두 범위에서 복사하려고합니다. C2 : G2 및 C5 : G56 이 작업을 간소화 된 방식으로 수행하고 싶습니다.

지금까지 답변 해 주신 것에 대해 많은 감사드립니다. 배열에 대한 정보를 읽고 5 페이지를 통해 작업하겠습니다!

리치

출처

2016-09-06 Rich Joyce

어떤 줄이 오류가 발생합니까? – Brian

안녕하세요. Brian, 저에게 다시 연락해 주셔서 감사합니다. 위의 업데이트를 게시했습니다. –

각 통합 문서에는 한 장만 있습니까? – Brian

는 다음을 설정하여 깜박이는 화면을 중지 할 수 있습니다

Application.ScreenUpdating = False

이 매크로에 그 추가하고 다시 실행하십시오.

출처

2016-09-06 11:30:42 Kier

고마워 - 잘됐다. 훨씬 좋네요! –

매크로 끝에 'Application.ScreenUpdating = True'를 다시 넣었는지 확인하십시오. – Brian

당신은 대신를 사용하여 "복사 & 붙여 넣기" 섹션을 빠르게 할 수 있어야한다 :

를 : 사용하여

With Workbooks("master").ActiveSheet 
    .Range("C2:F2").Value = Workbooks("2016_JAMAL").ActiveSheet.Range("G2:J2").Value 
    .Range("C3:F3").Value = Workbooks("2016_LOKESH").ActiveSheet.Range("G2:J2").Value 
    .Range("C4:F4").Value = Workbooks("2016_NONI").ActiveSheet.Range("G2:J2").Value 
    .Range("C5:F5").Value = Workbooks("2016_RAJESH").ActiveSheet.Range("G2:J2").Value 
    .Range("C6:F6").Value = Workbooks("2016_SANTHOSH").ActiveSheet.Range("G2:J2").Value 
    .Range("C7:F7").Value = Workbooks("2016_WARREN").ActiveSheet.Range("G2:J2").Value 
    .Range("C8:F8").Value = Workbooks("2016_7").ActiveSheet.Range("G2:J2").Value 
    .Range("C9:F9").Value = Workbooks("2016_8").ActiveSheet.Range("G2:J2").Value 
    .Range("C10:F10").Value = Workbooks("2016_9").ActiveSheet.Range("G2:J2").Value 
End With

당신은 또한 당신의 "가까운" 부분은 간단하게 만들 수

Workbooks("2016_JAMAL.xlsx").Close False 
Workbooks("2016_LOKESH.xlsx").Close False 
Workbooks("2016_NONI.xlsx").Close False 
Workbooks("2016_RAJESH.xlsx").Close False 
Workbooks("2016_SANTHOSH.xlsx").Close False 
Workbooks("2016_WARREN.xlsx").Close False 
Workbooks("2016_7.xlsx").Close False 
Workbooks("2016_8.xlsx").Close False 
Workbooks("2016_9.xlsx").Close False

출처

2016-09-06 12:43:29

배열이나 통합 문서 모음의 전체를 반복합니다. – Parfait

사실 매크로 레코딩에서는 OP가 쉽게 이해할 수있는 것보다 더 복잡하게 만들고 싶지 않았습니다. –

고마워 -이 분들의 훌륭한 의견입니다. Tim -이 변경 사항을 확실히 적용 할 것입니다. 파르페 - 배우기를 열망합니다 - 제가 공부할 수있는 요점을 논의하는 또 다른 주제가 있습니까? –

Activesheet 각 통합 문서의 시트 수 또는 이름을 알지 못했습니다. 그에 따라 조정할 수 있습니다.

Option Explicit 

Sub MergeAll2() 

Dim wb2016_7 As Workbook 
Dim wb2016_8 As Workbook 
Dim wb2016_9 As Workbook 
Dim wb2016_JAMAL As Workbook 
Dim wb2016_LOKESH As Workbook 
Dim wb2016_NONI As Workbook 
Dim wb2016_RAJESH As Workbook 
Dim wb2016_SANTHOSH As Workbook 
Dim wb2016_WARREN As Workbook 
Dim strPath As String 

Application.ScreenUpdating = False 

strPath = "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\" 

Set wb2016_7 = Workbooks.Open(Filename:=strPath & "2016_7.xlsx") 
Set wb2016_8 = Workbooks.Open(Filename:=strPath & "2016_8.xlsx") 
Set wb2016_9 = Workbooks.Open(Filename:=strPath & "2016_9.xlsx") 
Set wb2016_JAMAL = Workbooks.Open(Filename:=strPath & "2016_JAMAL.xlsx") 
Set wb2016_LOKESH = Workbooks.Open(Filename:=strPath & "2016_LOKESH.xlsx") 
Set wb2016_NONI = Workbooks.Open(Filename:=strPath & "2016_NONI.xlsx") 
Set wb2016_RAJESH = Workbooks.Open(Filename:=strPath & "2016_RAJESH.xlsx") 
Set wb2016_SANTHOSH = Workbooks.Open(Filename:=strPath & "2016_SANTHOSH.xlsx") 
Set wb2016_WARREN = Workbooks.Open(Filename:=strPath & "2016_WARREN.xlsx") 

With Workbooks("master").ActiveSheet 
    .Range("C2:F2").Value = wb2016_JAMAL.ActiveSheet.Range("G2:J2").Value 
    .Range("C3:F3").Value = wb2016_LOKESH.ActiveSheet.Range("G2:J2").Value 
    .Range("C4:F4").Value = wb2016_NONI.ActiveSheet.Range("G2:J2").Value 
    .Range("C5:F5").Value = wb2016_RAJESH.ActiveSheet.Range("G2:J2").Value 
    .Range("C6:F6").Value = wb2016_SANTHOSH.ActiveSheet.Range("G2:J2").Value 
    .Range("C7:F7").Value = wb2016_WARREN.ActiveSheet.Range("G2:J2").Value 
    .Range("C8:F8").Value = wb2016_7.ActiveSheet.Range("G2:J2").Value 
    .Range("C9:F9").Value = wb2016_8.ActiveSheet.Range("G2:J2").Value 
    .Range("C10:F10").Value = wb2016_9.ActiveSheet.Range("G2:J2").Value 
End With 

wb2016_7.Close True 
wb2016_8.Close True 
wb2016_9.Close True 
wb2016_JAMAL.Close True 
wb2016_LOKESH.Close True 
wb2016_NONI.Close True 
wb2016_RAJESH.Close True 
wb2016_SANTHOSH.Close True 
wb2016_WARREN.Close True 

Set wb2016_7 = Nothing 
Set wb2016_8 = Nothing 
Set wb2016_9 = Nothing 
Set wb2016_JAMAL = Nothing 
Set wb2016_LOKESH = Nothing 
Set wb2016_NONI = Nothing 
Set wb2016_RAJESH = Nothing 
Set wb2016_SANTHOSH = Nothing 
Set wb2016_WARREN = Nothing 

Application.ScreenUpdating = True 

End Sub

그것은 당신의 변수를 선언하도록 강제 Option Explicit을 사용하고 사용 후 Nothing에 다시 객체를 설정하는 좋은 연습입니다 : 여기 내 버전입니다.

내가 통합 문서의 각 Sheets("SheetName")으로 Activesheet을 대체 할

편집 할 수 있습니다. 그렇지 않으면 모든 통합 문서에 대한 통합 문서 객체에 다음 코드를 넣어 (매크로를 사용할 수있는 모든으로 저장) 마스터를 제외하고 Activesheet 유지 수 :

Private Sub Workbook_Open() 
    Sheets ("SheetName").Activate 
End Sub

나는, 적어도, Workbooks("master").Sheets("SheetName") 또는 당신에게 Workbooks("master").ActiveSheet을 바꿀 것 올바른 (즉, 활성화 된) 시트에서 실행하는 것을 기억해야합니다. 이것은 매우 유용한 link입니다.

출처

2016-09-07 10:32:06 Brian

안녕하세요 Brian, 좋은 조언입니다. 내 변수를 통합 문서의 특정 워크 시트로 만들려면 어떻게해야합니까? 올바른 방향으로 나를 가리켜 줄 수 있습니까? 그러면 내가 어디로 가는지 보여줄 것입니다. 많은 감사 –

@RichJoyce 위의 편집을 참조하십시오. 나는 그것이 도움이되기를 바랍니다. :) – Brian

한 가지 더, 수식 사용을 고려해 보셨습니까? 수식이있는 닫힌 통합 문서에서 데이터를 가져올 수 있습니다. – Brian

이렇게하면 폴더의 모든 통합 문서의 범위가 병합됩니다 (다음 데이터 집합은 이전보다 작음).

Sub Basic_Example_1() 
    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 

    'Fill in the path\folder where the files are 
    MyPath = "C:\Users\Ron\test" 

    '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 

    'Add a new workbook with one sheet 
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) 
    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)) 
      On Error GoTo 0 

      If Not mybook Is Nothing Then 

       On Error Resume Next 

       With mybook.Worksheets(1) 
        Set sourceRange = .Range("A1:C1") 
       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 
         With sourceRange 
          BaseWks.cells(rnum, "A"). _ 
            Resize(.Rows.Count).Value = MyFiles(Fnum) 
         End With 

         '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 
       mybook.Close savechanges:=False 
      End If 

     Next Fnum 
     BaseWks.Columns.AutoFit 
    End If 

ExitTheSub: 
    'Restore ScreenUpdating, Calculation and EnableEvents 
    With Application 
     .ScreenUpdating = True 
     .EnableEvents = True 
     .Calculation = CalcMode 
    End With 
End Sub

이렇게하면 폴더의 모든 통합 문서의 범위가 병합됩니다 (다음 데이터 집합은 이전의 오른쪽으로 이동).

Sub Basic_Example_3() 
    Dim MyPath As String, FilesInPath As String 
    Dim MyFiles() As String 
    Dim SourceCcount As Long, Fnum As Long 
    Dim mybook As Workbook, BaseWks As Worksheet 
    Dim sourceRange As Range, destrange As Range 
    Dim Cnum As Long, CalcMode As Long 

    'Fill in the path\folder where the files are 
    MyPath = "C:\Users\Ron\test" 

    '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 

    'Add a new workbook with one sheet 
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) 
    Cnum = 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)) 
      On Error GoTo 0 

      If Not mybook Is Nothing Then 

       On Error Resume Next 
       Set sourceRange = mybook.Worksheets(1).Range("A1:A10") 

       If Err.Number > 0 Then 
        Err.Clear 
        Set sourceRange = Nothing 
       Else 
        'if SourceRange use all rows then skip this file 
        If sourceRange.Rows.Count >= BaseWks.Rows.Count Then 
         Set sourceRange = Nothing 
        End If 
       End If 
       On Error GoTo 0 

       If Not sourceRange Is Nothing Then 

        SourceCcount = sourceRange.Columns.Count 

        If Cnum + SourceCcount >= BaseWks.Columns.Count Then 
         MsgBox "Sorry there are not enough columns in the sheet" 
         BaseWks.Columns.AutoFit 
         mybook.Close savechanges:=False 
         GoTo ExitTheSub 
        Else 

         'Copy the file name in the first row 
         With sourceRange 
          BaseWks.cells(1, Cnum). _ 
            Resize(, .Columns.Count).Value = MyFiles(Fnum) 
         End With 

         'Set the destrange 
         Set destrange = BaseWks.cells(2, Cnum) 

         '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 

         Cnum = Cnum + SourceCcount 
        End If 
       End If 
       mybook.Close savechanges:=False 
      End If 

     Next Fnum 
     BaseWks.Columns.AutoFit 
    End If 

ExitTheSub: 
    'Restore ScreenUpdating, Calculation and EnableEvents 
    With Application 
     .ScreenUpdating = True 
     .EnableEvents = True 
     .Calculation = CalcMode 
    End With 

End Sub

출처

2016-11-24 10:08:28

다른 Excel 통합 문서에서 데이터 병합

답변

관련 문제