Merging several databases together

S

STEFAN BEAN

I have several users inputing data into their spreadsheets with the same
column headings but for their particular group.

I need all these spreadsheets merged into one so that I can analyze all the
data.

How do you do this?

-Stef
 
D

Dave Peterson

Copy and paste the data from one worksheet into one giant worksheet?

When I do this stuff, I'm usually working with values. I don't want the
formulas. I don't want to worry about duplicate range names. So I'll just
copy|paste special|values.

If that sounds ok to you, maybe this macro would work nicely, too. (copy all
your workbooks in a dedicated folder. The macro will open all that it finds.
And it copies A1 through the last used cell of the first worksheet in the
workbook.

Option Explicit
Sub testme01()

Application.ScreenUpdating = False

Dim myFiles() As String
Dim fCtr As Long
Dim iCtr As Long
Dim myFile As String
Dim myPath As String
Dim tempWks As Worksheet
Dim AllWks As Worksheet
Dim oRow As Long
Dim rngToCopy As Range
Dim dummyRng As Range

Set AllWks = Workbooks.Add(1).Worksheets(1)
AllWks.Name = "All_" & Format(Date, "yyyymmdd_hhmmss")
oRow = 1

myPath = "c:\my documents\excel\test"
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
End If

myFile = Dir(myPath & "*.xls")
If myFile = "" Then
MsgBox "no files found"
Exit Sub
End If

'get the list of files
fCtr = 0
Do While myFile <> ""
fCtr = fCtr + 1
ReDim Preserve myFiles(1 To fCtr)
myFiles(fCtr) = myFile
myFile = Dir()
Loop

If fCtr > 0 Then
For iCtr = LBound(myFiles) To UBound(myFiles)
Application.StatusBar _
= "Processing: " & myFiles(iCtr) & " at: " & Now
Set tempWks = Nothing
On Error Resume Next
Application.EnableEvents = False
Set tempWks = Workbooks.Open(Filename:=myPath & myFiles(iCtr), _
ReadOnly:=True, UpdateLinks:=0).Worksheets(1)
Application.EnableEvents = True
If tempWks Is Nothing Then
MsgBox "couldn't open: " & myPath & myFiles(iCtr)
Else
With tempWks
Set dummyRng = .UsedRange 'try to reset usedrange
Set rngToCopy = .Range("a1", .UsedRange)
End With
rngToCopy.Copy
AllWks.Cells(oRow, "A").PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
oRow = oRow + rngToCopy.Rows.Count
tempWks.Parent.Close SaveChanges:=False
End If
Next iCtr
AllWks.UsedRange.Columns.AutoFit
Else
AllWks.Parent.Close SaveChanges:=False
End If

With Application
.ScreenUpdating = True
.StatusBar = False
End With

End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top