Question : Merging excel spreadsheets

we had 8 people working on a 40mb shared excel file, we kept running into problems with them not being able to save etc so we basically saved 8 copies of the spreadsheet and people are working on just their own one now.

However for reporting issues we now need to merge these spreadsheets back together once a day (hopefully keeping the users on their individual files). Is there any easy way to do this? I have tried using the consolidation tool with no luck. And the Merge tool means we have to do each spreadsheet one at a time (and it takes a good 2-3 minutes to load once we do it)

So basically just looking for an easier way to accomplish this.

Answer : Merging excel spreadsheets

CaptainGiblets,

The code below is in the attached file. To use you will need to:

1. Place all the files to be processed in a folder of their own. Place the attached file in a different folder.

2. Update this line of code in the macro to suit your set-up ie. where you've place the files to be processed:

Set fld = fso.GetFolder("C:\Documents and Settings\Patrick & Thuc-Nghi\My Documents\Patrick's\Excel files\CaptG\")

3. Press the button to run the macro.

Hope that helps

Patrick

                       
         
           
             1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:

           
           
             Sub ProcessFromFolder()
'This macro opens each file in turn and extracts the data from it, records it in the database,
'closes the file, and moves on to the next file. The macro also records the file name so that
'it will only process a file if it has not been processed before. It uses a 'collection' for
'the file names.

    Dim fso As Object, fld As Object, fil As Object
    Dim coll As New Collection
    Dim FileListWs As Worksheet
    Dim SourceWs As Worksheet
    Dim SourceWb As Workbook
    Dim DestWs As Worksheet
    Dim TotFiles As Long
    Dim Counter As Long
    Dim WasOpen As Boolean
    Dim i As Long
    Dim rowe As Long
    Dim col As Long
    Dim lastrow As Long
    Dim errorflag As String
    
    Application.ScreenUpdating = False
    
    errorflag = ""

    ' Determine files processed already
    Set FileListWs = ThisWorkbook.Worksheets("File List")
    Set DestWs = ThisWorkbook.Worksheets("Database")
    With FileListWs
        TotFiles = Application.CountA(.[a:a])
        If TotFiles > 0 Then
            For Counter = 1 To TotFiles
                coll.Add .Cells(Counter, 1), .Cells(Counter, 1)
            Next
        End If
    End With

    'look at folder
    Set fso = CreateObject("Scripting.FileSystemObject")
    'put full path to folder containing data files in the next line of code
    Set fld = fso.GetFolder("C:\Documents and Settings\Patrick & Thuc-Nghi\My Documents\Patrick's\Excel files\CaptG\")
       
    For Each fil In fld.Files
        On Error Resume Next
        coll.Add fil.Name, fil.Name
        If Err <> 0 Then
            'file already processed, do nothing
            Err.Clear
        Else
            'not processed yet; process it
            With FileListWs
                If TotFiles = 0 Then
                    .[A2] = fil.Name
                Else
                    '.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0) = fil.Name
                    .Cells(65536, 1).End(xlUp).Offset(1, 0) = fil.Name
                End If
            End With
            'see if it's already open
            Set SourceWb = Workbooks(fil.Name)
            If Err <> 0 Then
                'was not open
                WasOpen = False
                Set SourceWb = Workbooks.Open(fil.Path)
            Else
                WasOpen = True
            End If
            
            Set SourceWs = SourceWb.Sheets(1)
            
            With SourceWs
                .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp).Offset(0, 14)).Copy _
                    DestWs.Cells(DestWs.Rows.Count, "A").End(xlUp).Offset(1, 0)
            End With
            
            errorflag = ""
            If Not WasOpen Then SourceWb.Close False
        End If
    Next

    Set coll = Nothing
    Set fil = Nothing
    Set fld = Nothing
    Set fso = Nothing
    
    Application.ScreenUpdating = True
    MsgBox "Done"

End Sub

           
         