Excel file splitter

[padinka]

Can someone help me with this? I need to take large files, which are sorted by area and split the rows for each area into individual workbooks.

Area City Dollars
AL Bham 5
AL Mnt 10
AL Hunt 5
TN Nash 6
TN Memphis 5

This would produce two workbooks, Alabama with three rows and a header and TN with two rows and a header.


Trisha
padinka@yahoo.com

 

[WinblowsME]

' Excel Spreadsheet Data
' Column 1:  Area
' Column 2:  City
' Column 3:  Dollars

Sub Split_Workbooks()
   Dim header1 As String, header2 As String, header3 As String
   Dim area As String, prev_area As String, city As String, dollars As Double
   Dim i As Long, j As Long, last_row As Long
   Dim data_workbook As Workbook, new_workbook As Workbook, path_name As String

   Set data_workbook = ActiveWorkbook

   With data_workbook.Sheets(1)
      header1 = Trim(.Cells(1, 1))
      header2 = Trim(.Cells(1, 2))
      header3 = Trim(.Cells(1, 3))
   End With
   
   path_name = "C:\Temp\"
   prev_area = ""
   last_row = ActiveSheet.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row

   Application.DisplayAlerts = False
   
   If last_row < 2 Then
      MsgBox "No data"
      Exit Sub
   End If
   
   For i = 2 To last_row
      With data_workbook.Sheets(1)
         area = Trim(.Cells(i, 1))
         city = Trim(.Cells(i, 2))
         dollars = Trim(.Cells(i, 3))
      End With

      If area = "" Then
         Exit For
      End If

      If area <> prev_area Then
         If prev_area <> "" Then
            new_workbook.SaveAs (path_name & prev_area & ".xls")
            new_workbook.Close
         End If

         Application.Workbooks.Add
         Set new_workbook = ActiveWorkbook

         j = 2
         Call Fill_Workbook(new_workbook, j, area, city, dollars, header1, header2, header3)
      Else
         j = j + 1

         Call Fill_Workbook(new_workbook, j, area, city, dollars)
      End If

      prev_area = area
   Next i

   new_workbook.SaveAs (path_name & prev_area & ".xls")
   new_workbook.Close
End Sub

Private Sub Fill_Workbook(new_workbook As Workbook, j As Long, _
                          area As String, city As String, dollars As Double, _
                          Optional header1 As String = "", Optional header2 As String = "", Optional header3 As String = "")
   With new_workbook.Sheets(1)
      If header1 <> "" Then
         .Cells(1, 1) = header1
         .Cells(1, 2) = header2
         .Cells(1, 3) = header3
      End If

      .Cells(j, 3).NumberFormat = "#,###.00_);[Red](#,###.00)"
      .Cells(j, 1) = area
      .Cells(j, 2) = city
      .Cells(j, 3) = dollars
   End With
End Sub

 

[padinka]

Well, that is good for the example but I'm looking for something a little more broad that would work regardless of the titles or whether they had 3 columns or 60 columns of data. Basically to copy the entire row.

Trisha
padinka@yahoo.com

 

[PHV]

And you really can't figure out how to improve WinblowsME's code to suit your issue ?
What have YOU tried so far ?

 

[WinblowsME]

Use the above code and play with

    data_workbook.Sheets(1).rows("7:7").Copy
    new_workbook.Sheets(1).Range("A13").PasteSpecial (xlPasteAll)

 

[WinblowsME]

Sub Split_Workbooks()
   Dim path_name As String, area As String, prev_area As String, 
   Dim i As Long, j As Long, last_row As Long
   Dim data_workbook As Workbook, new_workbook As Workbook

   Set data_workbook = ActiveWorkbook
   
   path_name = "C:\Temp\"
   prev_area = ""
   last_row = ActiveSheet.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row

   Application.DisplayAlerts = False
   
   If last_row < 2 Then
      MsgBox "No data"
      Exit Sub
   End If
   
   For i = 2 To last_row
      area = Trim(data_workbook.Sheets(1).Cells(i, 1))

      If area = "" Then
         Exit For
      End If

      If area <> prev_area Then
         If prev_area <> "" Then
            new_workbook.Sheets(1).Range("A1").Select
            new_workbook.SaveAs (path_name & prev_area & ".xls")
            new_workbook.Close
         End If

         Application.Workbooks.Add
         Set new_workbook = ActiveWorkbook

         j = 2
         
         data_workbook.Sheets(1).Rows("1:1").Copy
         new_workbook.Sheets(1).Range("A1").PasteSpecial (xlPasteAll)
         
         data_workbook.Sheets(1).Rows(i & ":" & i).Copy
         new_workbook.Sheets(1).Range("A" & j).PasteSpecial (xlPasteAll)
      Else
         j = j + 1

         data_workbook.Sheets(1).Rows(i & ":" & i).Copy
         new_workbook.Sheets(1).Range("A" & j).PasteSpecial (xlPasteAll)
      End If

      prev_area = area
   Next i

   new_workbook.Sheets(1).Range("A1").Select
   new_workbook.SaveAs (path_name & prev_area & ".xls")
   new_workbook.Close
End Sub

 

[xlbo]

Personally, rather than looping to get the data, I would

1: use Advanced filter to generate a unique list of areas
2: Loop through that much shorter list, applying an autofilter using each value in turn
3: Select all cells and copy to new workbook

The beauty of this is that you don't need to know how many cells have been filtered as when you do a copy form a filtered selection, you only copy the filtered cells

Macro recorder will give you a good start for this - perform the action manually and then add a loop into the code

Rgds, Geoff

We could learn a lot from crayons. Some are sharp, some are pretty and some are dull. Some have weird names and all are different colours but they all live in the same box.

Please read FAQ222-2244 before you ask a question