[mso] Re: Excel Macro Question

Hi Christine,

The below code is Q&D but should do what you want.

It assumes the office name is in A1. If it isn't then you will have to
alter that and the bit that does the sort.
You should be in the sheet you want to split up when you run it. It
will create a sheet for any office that doesn't have one.

The bit that goes to the last cell in A1 to paste the data on the end
is really ugly. Can anyone help tidy that up please?

HTH
Lisa

> The office codes won't change, but not all office codes
> will be in every
> report and the number of lines per office will vary.  There are 14
> offices in total, but again, not all offices will
> necessarily be in each
> report.  One idea I got was to filter the data for each
> office and copy
> the filtered data to a new tab.
>
> Thanks,
>
> Christine McDonald, CPA

Sub subSplitData()
' Split up into seperate offices.

Dim ilERow As Integer
Dim ilECol As Integer
Dim ilSCol As Integer
Dim olCell As Range
Dim olCellA As Range
Dim ilSRow As Integer
Dim olCRange As Range
Dim rlWorkRange As Range
Dim slWorkbook As String
Dim slECol As String
Dim ilECol1 As Integer
Dim rlOfficeNames As Range
Dim ilNumOffices As Integer
Dim slNewOffice As String
Dim slOldOffice As String
Dim slOfficeSheet As String
Dim slMainSheet As String


' Get end row/column.
' Raw data... no totals.
' Assumes no blank cells.
Range("A1").Select
Selection.End(xlDown).Select
Selection.End(xlToRight).Select
ilERow = ActiveCell.Row
ilECol = ActiveCell.Column
slECol = ""
slMainSheet = ActiveSheet.Name

' Sort.
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort _
    Key1:=Range("A1"), _
    Order1:=xlAscending, _
    Header:=xlGuess, _
    OrderCustom:=1, _
    MatchCase:=False, _
    Orientation:=xlTopToBottom

Range("A1").Select
Set rlOfficeNames = _
    Range("A1", _
        Cells(ilERow + 1, 1))

' Loop Through data.
ilNumOffices = 0
slNewOffice = ""
slOldOffice = ""
ilSRow = 1
For Each olCell In rlOfficeNames
  slNewOffice = UCase$(Trim$(olCell.Text))
  If slNewOffice <> slOldOffice Then
    If olCell.Row > 1 Then

      slOfficeSheet = slOldOffice

      ' Copy data.
      Set olCRange = _
          Range(Cells(ilSRow, 1), _
          Cells(olCell.Row - 1, ilECol))
      olCRange.Copy

      On Error Resume Next
      Sheets(slOfficeSheet).Activate
      If Err.Number <> 0 Then
        Sheets.Add
        ActiveSheet.Name = slOfficeSheet ' Sheets("Sheet6").Name =
"Office12"
      End If
      On Error GoTo 0

      Range("a1").Select
      Selection.End(xlDown).Select
      If ActiveCell.Row = 65536 Then
        Range("a1").Select
        If ActiveCell.Text <> "" Then
          ActiveCell.Offset(1, 0).Select
        End If
      Else
        ActiveCell.Offset(1, 0).Select
      End If
      ActiveSheet.Paste
      Sheets(slMainSheet).Select

      ' Set the start row to this one for the next
      '  Office.
      ilSRow = olCell.Row
    End If
    slOldOffice = slNewOffice
  End If
Next olCell
Range("a1").Select
MsgBox "Done."
'
**********************************************************************
******
End Sub


*************************************************************
You are receiving this mail because you subscribed to mso@xxxxxxxxxxxxx or 
MicrosoftOffice@xxxxxxxxxxxxxxxx

To send mail to the group, simply address it to mso@xxxxxxxxxxxxx

To Unsubscribe from this group, send an email to 
mso-request@xxxxxxxxxxxxx with the word "unsubscribe" (without the quotes) in 
the subject line.

Or, visit the group's homepage and use the dropdown menu.  This will also allow 
you to change your email settings to digest or vacation (no mail).
http://www.freelists.org/webpage/mso

To be able to use the files section for sharing files with the group, send a 
request to mso-moderators@xxxxxxxxxxxxx and you will be sent an invitation with 
instructions.  Once you are a member of the files group, you can go here to 
upload/download files:
http://www.smartgroups.com/vault/msofiles
*************************************************************

Other related posts: