Advertisement
Guest User

Untitled

a guest
Feb 24th, 2012
342
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Sub MergeAllWorkbooks()
  2.     Dim MyPath As String, FilesInPath As String
  3.     Dim MyFiles() As String
  4.     Dim SourceRcount As Long, FNum As Long
  5.     Dim mybook As Workbook, BaseWks As Worksheet
  6.     Dim sourceRange As Range, destrange As Range
  7.     Dim rnum As Long, CalcMode As Long
  8.  
  9.     ' Change this to the path\folder location of your files.
  10.    MyPath = "C:\test\"
  11.  
  12.     ' Add a slash at the end of the path if needed.
  13.    If Right(MyPath, 1) <> "\" Then
  14.         MyPath = MyPath & "\"
  15.     End If
  16.  
  17.     ' If there are no Excel files in the folder, exit.
  18.    FilesInPath = Dir(MyPath & "*.xl*")
  19.     If FilesInPath = "" Then
  20.         MsgBox "No files found"
  21.         Exit Sub
  22.     End If
  23.  
  24.     ' Fill the myFiles array with the list of Excel files
  25.    ' in the search folder.
  26.    FNum = 0
  27.     Do While FilesInPath <> ""
  28.         FNum = FNum + 1
  29.         ReDim Preserve MyFiles(1 To FNum)
  30.         MyFiles(FNum) = FilesInPath
  31.         FilesInPath = Dir()
  32.     Loop
  33.     FNum = FNum - 1
  34.    
  35.     ' Set various application properties.
  36.    With Application
  37.         CalcMode = .Calculation
  38.         .Calculation = xlCalculationManual
  39.         .ScreenUpdating = False
  40.         .EnableEvents = False
  41.     End With
  42.  
  43.     ' Add a new workbook with one sheet.
  44.    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
  45.     rnum = 1
  46.  
  47.     ' Loop through all files in the myFiles array.
  48.    If FNum > 0 Then
  49.         For FNum = LBound(MyFiles) To UBound(MyFiles)
  50.             Set mybook = Nothing
  51.             On Error Resume Next
  52.             Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
  53.             On Error GoTo 0
  54.  
  55.             If Not mybook Is Nothing Then
  56.                 On Error Resume Next
  57.  
  58.                 ' Change this range to fit your own needs.
  59.              With mybook.Worksheets(1)
  60.                     Set sourceRange = .Range("A2:T" & CStr(mybook.Worksheets(1).Range("A2").CurrentRegion.Rows.Count))
  61.                 End With
  62.  
  63.                 If Err.Number > 0 Then
  64.                     Err.Clear
  65.                     Set sourceRange = Nothing
  66.                 Else
  67.                     ' If source range uses all columns then
  68.                    ' skip this file.
  69.                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
  70.                         Set sourceRange = Nothing
  71.                     End If
  72.                 End If
  73.                 On Error GoTo 0
  74.  
  75.                 If Not sourceRange Is Nothing Then
  76.  
  77.                     SourceRcount = sourceRange.Rows.Count
  78.  
  79.                     If rnum + SourceRcount >= BaseWks.Rows.Count Then
  80.                         MsgBox "There are not enough rows in the target worksheet."
  81.                         BaseWks.Columns.AutoFit
  82.                         mybook.Close savechanges:=False
  83.                         GoTo ExitTheSub
  84.                     Else
  85.  
  86.                         ' Copy the file name in column A.
  87.                        With sourceRange
  88.                             BaseWks.Cells(rnum, "A"). _
  89.                                     Resize(.Rows.Count).Value = MyFiles(FNum)
  90.                         End With
  91.  
  92.                         ' Set the destination range.
  93.                        Set destrange = BaseWks.Range("B" & rnum)
  94.  
  95.                         ' Copy the values from the source range
  96.                        ' to the destination range.
  97.                        With sourceRange
  98.                             Set destrange = destrange. _
  99.                                             Resize(.Rows.Count, .Columns.Count)
  100.                         End With
  101.                         destrange.Value = sourceRange.Value
  102.  
  103.                         rnum = rnum + SourceRcount
  104.                     End If
  105.                 End If
  106.                 mybook.Close savechanges:=False
  107.             End If
  108.  
  109.         Next FNum
  110.         BaseWks.Columns.AutoFit
  111.     End If
  112.  
  113. ExitTheSub:
  114.     ' Restore the application properties.
  115.    With Application
  116.         .ScreenUpdating = True
  117.         .EnableEvents = True
  118.         .Calculation = CalcMode
  119.     End With
  120. End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement