Dennis,
The best way would be to break your database into separate workbooks using
the first macro below. This macro assumes that your database is on the only
sheet in the workbook. It would be best if you first saved the database in a
separate folder that contains nothing other than the database - that's where
the separate files will be placed.
Once they are broken into separate files, e-mail them out for changes.
As each comes back, put them into another, different, dedicated folder. When
all the workbooks are back, combine them back into one database, using the
second macro below. To do that, create a new workbook for the macro, and
save the new workbook in the dedicated folder, then run the macro.
HTH,
Bernie
MS Excel MVP
Sub ExportDatabaseToSeparateFiles()
'Export is based on the value in the desired column
Dim myCell As Range
Dim mySht As Worksheet
Dim myName As String
Dim myArea As Range
Dim myShtName As String
Dim KeyCol As Integer
myShtName = ActiveSheet.Name
'If your data is in B2
10, and you want to use column C, answer 2 to the
next question
KeyCol = InputBox("What column # within database to use as key?")
Set myArea = ActiveCell.CurrentRegion.Columns(KeyCol).Offset(1, 0).Cells
Set myArea = myArea.Resize(myArea.Rows.Count - 1, 1)
For Each myCell In myArea
On Error GoTo NoSheet
myName = Worksheets(myCell.Value).Name
GoTo SheetExists:
NoSheet:
Set mySht = Worksheets.Add(before:=Worksheets(1))
mySht.Name = myCell.Value
With myCell.CurrentRegion
.AutoFilter Field:=KeyCol, Criteria1:=myCell.Value
.SpecialCells(xlCellTypeVisible).Copy _
mySht.Range("A1")
mySht.Cells.EntireColumn.AutoFit
.AutoFilter
End With
Resume
SheetExists:
Next myCell
For Each mySht In ActiveWorkbook.Worksheets
If mySht.Name = myShtName Then
Exit Sub
Else
mySht.Move
ActiveWorkbook.SaveAs "Workbook " & ActiveSheet.Name & ".xls"
ActiveWorkbook.Close
End If
Next mySht
End Sub
Sub Consolidate()
' Will consolidate Mulitple Sheets
' from Multiple Files onto one sheet
' Assumes that all data starts in cell A1 and
' is contiguous, with no blanks in column A
With Application
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
End With
With Application.FileSearch
.NewSearch
'Change this to your directory
.LookIn = ThisWorkbook.Path
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
Set Basebook = ThisWorkbook
For i = 1 To .FoundFiles.Count
If .FoundFiles(i) <> ThisWorkbook.FullName Then
Set myBook = Workbooks.Open(.FoundFiles(i))
For Each mySheet In myBook.Worksheets
mySheet.Activate
Range("A1").CurrentRegion.Copy _
Basebook.Worksheets(1).Range("C65536").End(xlUp).Offset(1,
0)
With Basebook.Worksheets(1)
.Range(.Range("A65536").End(xlUp).Offset(1, 0), _
.Range("C65536").End(xlUp).Offset(0, -2)).Value = _
myBook.Name
.Range(.Range("B65536").End(xlUp).Offset(1, 0), _
.Range("C65536").End(xlUp).Offset(0, -1)).Value = _
mySheet.Name
End With
Next mySheet
myBook.Close
End If
Next i
End If
End With
With Application
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
End With
Basebook.SaveAs Application.GetSaveAsFilename
End Sub
