I am in dire need of macro help!

[Nora]

Hey guys. I am working on a project for my Controller and have run
into quite a road block. Here is the issue... I have a chunk of data
from column A-N that is several thousand lines long. In column C is
the department number which changes every few hundred lines. For
example, from lines 1-150 is the department number 2240, in rows
150-220 is department number 2241 and so forth until the end of the
data set(each set of department numbers does not have the same number
of lines). There are 30 such department numbers. I need to be able to
take the first chunk of data, from column A-N, down to the end of
department 2240 and paste it into a separate tab. Then I need to pull
the second chunk of data with department 2241 and place it in a second
tab and so firth until all of the data has been split into 30 different
tabs. I have tried a formula to pull the lines corresponding to each
department but the file is so large after 5 tabs that it is unusable.
Thus, I need a macro. Here is an example of what I need using only
five columns. Each space represents a new cell...

A Kim 2240 $580.00 2/3
B Leah 2240 $263.00 2/8
C Angelita 2240 %1967.00 2/3
D Mason 2240 $423.95 1/30
E Kate 2241 $36.45 1/17
F Sumera 2241 $214.35 4/25
G Annette 2241 $673.87 2/18

I need to be able to pull the first four rows into the frist tab and
the next three rows into the second tab and so forth(if there was more
data). I know this is a complex project but does anyone have any
ideas?

Thanks!!
Nora Church
(e-mail address removed)

 

[Mat P:son]

Hi there Nora,

I've put together a bunch of VBA lines that will help you do the job. There
are a few "TODO:" tags in the code where you need to tweak some of the code
to better fit your particular situation, but there aren't really that many of
them.

If you have any questions or comment, you're more than welcome to give me a
shout...

Cheers,
/MP

(Oh, and any bugs you will find in the code are probably someone else's

=========================================

Option Explicit

Private Const DeptColumn As Integer = 2

Private Const ErrorNone As Long = 0
Private Const ErrorInvalidArg As Long = 5

' The current workbook, and the source sheet
Private m_oWorkbook As Workbook
Private m_oSrcSheet As Worksheet

' Can be either a Chart and a Worksheet
Private m_oOldSheet As Object

Private m_lFirstRow As Long
Private m_lLastRow As Long

' This will be a collection of departments, and
' each department will hold a collection of rows
Private m_oDepartments As Collection


' TODO:
' Invoke this method to do the job!
Public Sub Main()
On Error GoTo ErrorHandler

InitMain
InitDepts
CopyDepts
TermMain

Finalize:
Exit Sub

ErrorHandler:
MsgBox _
"Error (" & CStr(Err.Number) & ") : " & _
Err.Description, _
vbOKOnly, _
"Error"

End Sub


' TODO:
' Fill in the correct (i.e., your) values here!
' Sheet1 is probably called something different,
' and m_lLastRow assumes all rows are contiguous
' (easy to fix, but I thought it'd be unnecessary)
Private Sub InitMain()
Application.ScreenUpdating = False

Set m_oWorkbook = Application.ActiveWorkbook
Set m_oOldSheet = Application.ActiveSheet
Set m_oSrcSheet = m_oWorkbook.Worksheets("Sheet1")

m_lFirstRow = 1
m_lLastRow = m_oSrcSheet.Cells(m_lFirstRow, 1).End(xlDown).Row
End Sub


' Read the source worksheet, and build up a collection
' of departments. And for each such department, collect
' all rows that are associated with the particular dept.
Private Sub InitDepts()
Set m_oDepartments = New Collection

Dim oDept As Collection
Dim iDept As Integer
Dim lRow As Long

On Error Resume Next
For lRow = m_lFirstRow To m_lLastRow
iDept = CInt(m_oSrcSheet.Cells(lRow, DeptColumn).Value)
Set oDept = m_oDepartments.Item(CStr(iDept))
If Err.Number = ErrorInvalidArg Then
' Department not yet present in
' collection, so let's add it.
' Use the Dept Code as the key.
Err.Clear
m_oDepartments.Add New Collection, CStr(iDept)
Set oDept = m_oDepartments.Item(CStr(iDept))
ElseIf Err.Number <> ErrorNone Then
' Other error? We won't handle it here!
Exit Sub
End If
oDept.Add m_oSrcSheet.Rows(lRow)
Next lRow
On Error GoTo 0
End Sub


' Add one new worksheet per department,
' and copy the associated rows one by one
Private Sub CopyDepts()
Dim oSheet As Worksheet

Dim oDept As Object
Dim oRow As Range
Dim lRow As Long

For Each oDept In m_oDepartments
' Add a new worksheet to the end of the ones we've
' already got, and give it a sensible name as well.
Set oSheet = m_oWorkbook.Worksheets.Add( _
After:=m_oWorkbook.Worksheets(m_oWorkbook.Worksheets.Count))
oSheet.Name = _
"Dept " & CStr(oDept.Item(1).Cells(1, DeptColumn).Value)

' Copy all the rows of this department
' and paste them into the new workbook
lRow = 1
For Each oRow In oDept
oRow.Copy
oSheet.Rows(lRow).PasteSpecial xlPasteAll
lRow = lRow + 1
Next oRow

oSheet.Cells(1, 1).Activate
Next oDept
End Sub


' Put things back to normal again
Private Sub TermMain()
m_oOldSheet.Activate
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

=========================================

 

[Mat P:son]

Oh, and in your case you should obviously change the value of the DeptColumn
from 2 to 3 (column B to column C)

/MP

 

[Nora]

Thanks so much for your help! I'll let you know whether or not I can
get it to work.

Nora

 

[Mat P:son]

You're welcome, Nora
/MP

Thanks so much for your help! I'll let you know whether or not I can
get it to work.

Nora