Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
I am in dire need of macro help!
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
I am in dire need of macro help!
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.Workshee ts.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 ========================================= "Nora" wrote: 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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
I am in dire need of macro help!
Oh, and in your case you should obviously change the value of the DeptColumn
from 2 to 3 (column B to column C) /MP "Mat P:son" wrote: 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.Workshee ts.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 ========================================= "Nora" wrote: 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 |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
I am in dire need of macro help!
Thanks so much for your help! I'll let you know whether or not I can
get it to work. Nora son wrote: 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.Workshee ts.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 ========================================= "Nora" wrote: 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 |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
I am in dire need of macro help!
You're welcome, Nora
/MP "Nora" wrote: Thanks so much for your help! I'll let you know whether or not I can get it to work. Nora son wrote: 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.Workshee ts.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 ========================================= "Nora" wrote: 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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Urgent! I am in dire trouble - boss says it can be done - How? | Excel Worksheet Functions | |||
how to count/sum by function/macro to get the number of record to do copy/paste in macro | Excel Programming | |||
In need of some dire help... | Excel Programming | |||
macro to delete entire rows when column A is blank ...a quick macro | Excel Programming | |||
Start Macro / Stop Macro / Restart Macro | Excel Programming |