Macro
 

I have the following Macro that I used to export from a database into
separate Excel files at the change of Each # in Column A in spreadsheet. Can
you please tell me if this would not work on Office 2007 - getting a debug
error.

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 String
Dim myField As Integer

myShtName = ActiveSheet.Name
KeyCol = InputBox("What column letter to use as key?")

Set myArea = Intersect(ActiveCell.CurrentRegion, Range(KeyCol &
"1").EntireColumn).Cells

Set myArea = myArea.Offset(1, 0).Resize(myArea.Rows.Count - 1, 1)
myField = myArea.Column - ActiveCell.CurrentRegion.Cells(1).Column + 1

For Each myCell In myArea
On Error GoTo NoSheet
myName = Worksheets(myCell.Value).Name
GoTo SheetExists:
NoSheet:
Set mySht = Worksheets.Add(Befo=Worksheets(1))
mySht.Name = myCell.Value
With myCell.CurrentRegion
..AutoFilter Field:=myField, 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

Macro
 

Can you give us a clue on where the error occurs? Also, you'll need to
specify the fileformat when you use saveas in Excel 2007.
--
HTH,

Barb Reinhardt



"Nikki" wrote:

I have the following Macro that I used to export from a database into
separate Excel files at the change of Each # in Column A in spreadsheet. Can
you please tell me if this would not work on Office 2007 - getting a debug
error.

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 String
Dim myField As Integer

myShtName = ActiveSheet.Name
KeyCol = InputBox("What column letter to use as key?")

Set myArea = Intersect(ActiveCell.CurrentRegion, Range(KeyCol &
"1").EntireColumn).Cells

Set myArea = myArea.Offset(1, 0).Resize(myArea.Rows.Count - 1, 1)
myField = myArea.Column - ActiveCell.CurrentRegion.Cells(1).Column + 1

For Each myCell In myArea
On Error GoTo NoSheet
myName = Worksheets(myCell.Value).Name
GoTo SheetExists:
NoSheet:
Set mySht = Worksheets.Add(Befo=Worksheets(1))
mySht.Name = myCell.Value
With myCell.CurrentRegion
.AutoFilter Field:=myField, 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