N
Nikki
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(Before:=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
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(Before:=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