Hi folks,

I need a help on Excel macro. I have a spreadsheet which called sheet1 and
has thousands of records and group by departments. I want to create a macro
which can move the same departments records to the new sheet and rename the
sheet to the department name. Could anyone show me the code? Any help will
be appreciated?

Thanks in advance.

Tim.

Try:

http://www.rondebruin.nl/copy5.htm#all

Hope this helps
Rowan

Tim wrote:
Hi folks,

I need a help on Excel macro. I have a spreadsheet which called sheet1 and
has thousands of records and group by departments. I want to create a macro
which can move the same departments records to the new sheet and rename the
sheet to the department name. Could anyone show me the code? Any help will
be appreciated?

Thanks in advance.

Tim.

keeping it really simple

Option Explicit
Sub test()
CopyRows "x"
End Sub

Sub CopyRows(dept As String)
Dim targetIndex As Long
Dim sourceIndex As Long
Dim targetSheet As Worksheet
Dim sourceSheet As Worksheet

Set sourceSheet = Worksheets("sheet1")
Set targetSheet = GetSheet(dept)

Application.ScreenUpdating = False

For sourceIndex = 1 To sourceSheet.Range("A65000").End(xlUp).Row

If sourceSheet.Cells(sourceIndex, 1).Value = dept Then

targetIndex = targetIndex + 1
targetSheet.Rows(targetIndex).Value = _
sourceSheet.Rows(sourceIndex).Value

End If

Next

Application.ScreenUpdating = True

End Sub
Function GetSheet(sheetsname As String) As Worksheet
On Error Resume Next
Set GetSheet = Worksheets(sheetsname)
If Err.Number = 0 Then
GetSheet.Cells.Clear
Else
Set GetSheet = Worksheets.Add
GetSheet.Name = sheetsname
End If
On Error GoTo 0
End Function


this should be easy enough. screen updating speeds things up quite a bit
we simple check each row to see if the cell in A matches teh dept, then we
copy it. we keep a record of which is the nest row to update.

Its probably faster to use 'FIND' so I'll add that routine in my next mail
shortly


"Tim" wrote:

Hi folks,

I need a help on Excel macro. I have a spreadsheet which called sheet1 and
has thousands of records and group by departments. I want to create a macro
which can move the same departments records to the new sheet and rename the
sheet to the department name. Could anyone show me the code? Any help will
be appreciated?

Thanks in advance.

Tim.

using FIND for speeier execution

Option Explicit
Sub test()
CopyRows "x"
End Sub

Sub CopyRows(dept As String)
Dim targetIndex As Long
Dim sourceIndex As Long
Dim targetSheet As Worksheet
Dim sourceSheet As Worksheet

Dim found As Range
Dim firstaddress As String

Set sourceSheet = Worksheets("sheet1")

Set targetSheet = GetSheet(dept)
Application.ScreenUpdating = False

Set found = sourceSheet.Range("A:A").Find(dept)
If Not found Is Nothing Then
firstaddress = found.Address
Do
targetIndex = targetIndex + 1
sourceIndex = found.Row
targetSheet.Rows(targetIndex).Value = _
sourceSheet.Rows(sourceIndex).Value
Set found = sourceSheet.Range("A:A").FindNext(found)
Loop Until firstaddress = found.Address

End If



Application.ScreenUpdating = True



End Sub
Function GetSheet(sheetsname As String) As Worksheet
On Error Resume Next
Set GetSheet = Worksheets(sheetsname)
If Err.Number = 0 Then
GetSheet.Cells.Clear
Else
Set GetSheet = Worksheets.Add
GetSheet.Name = sheetsname
End If
On Error GoTo 0
End Function



"Patrick Molloy" wrote:

keeping it really simple

Option Explicit
Sub test()
CopyRows "x"
End Sub

Sub CopyRows(dept As String)
Dim targetIndex As Long
Dim sourceIndex As Long
Dim targetSheet As Worksheet
Dim sourceSheet As Worksheet

Set sourceSheet = Worksheets("sheet1")
Set targetSheet = GetSheet(dept)

Application.ScreenUpdating = False

For sourceIndex = 1 To sourceSheet.Range("A65000").End(xlUp).Row

If sourceSheet.Cells(sourceIndex, 1).Value = dept Then

targetIndex = targetIndex + 1
targetSheet.Rows(targetIndex).Value = _
sourceSheet.Rows(sourceIndex).Value

End If

Next

Application.ScreenUpdating = True

End Sub
Function GetSheet(sheetsname As String) As Worksheet
On Error Resume Next
Set GetSheet = Worksheets(sheetsname)
If Err.Number = 0 Then
GetSheet.Cells.Clear
Else
Set GetSheet = Worksheets.Add
GetSheet.Name = sheetsname
End If
On Error GoTo 0
End Function


this should be easy enough. screen updating speeds things up quite a bit
we simple check each row to see if the cell in A matches teh dept, then we
copy it. we keep a record of which is the nest row to update.

Its probably faster to use 'FIND' so I'll add that routine in my next mail
shortly


"Tim" wrote:

Hi folks,

I need a help on Excel macro. I have a spreadsheet which called sheet1 and
has thousands of records and group by departments. I want to create a macro
which can move the same departments records to the new sheet and rename the
sheet to the department name. Could anyone show me the code? Any help will
be appreciated?

Thanks in advance.

Tim.

Patrick and Rowan,

Thank you very much for your help and time. The solutions work great.

Tim.

"Patrick Molloy" wrote:

using FIND for speeier execution

Option Explicit
Sub test()
CopyRows "x"
End Sub

Sub CopyRows(dept As String)
Dim targetIndex As Long
Dim sourceIndex As Long
Dim targetSheet As Worksheet
Dim sourceSheet As Worksheet

Dim found As Range
Dim firstaddress As String

Set sourceSheet = Worksheets("sheet1")

Set targetSheet = GetSheet(dept)
Application.ScreenUpdating = False

Set found = sourceSheet.Range("A:A").Find(dept)
If Not found Is Nothing Then
firstaddress = found.Address
Do
targetIndex = targetIndex + 1
sourceIndex = found.Row
targetSheet.Rows(targetIndex).Value = _
sourceSheet.Rows(sourceIndex).Value
Set found = sourceSheet.Range("A:A").FindNext(found)
Loop Until firstaddress = found.Address

End If



Application.ScreenUpdating = True



End Sub
Function GetSheet(sheetsname As String) As Worksheet
On Error Resume Next
Set GetSheet = Worksheets(sheetsname)
If Err.Number = 0 Then
GetSheet.Cells.Clear
Else
Set GetSheet = Worksheets.Add
GetSheet.Name = sheetsname
End If
On Error GoTo 0
End Function



"Patrick Molloy" wrote:

keeping it really simple

Option Explicit
Sub test()
CopyRows "x"
End Sub

Sub CopyRows(dept As String)
Dim targetIndex As Long
Dim sourceIndex As Long
Dim targetSheet As Worksheet
Dim sourceSheet As Worksheet

Set sourceSheet = Worksheets("sheet1")
Set targetSheet = GetSheet(dept)

Application.ScreenUpdating = False

For sourceIndex = 1 To sourceSheet.Range("A65000").End(xlUp).Row

If sourceSheet.Cells(sourceIndex, 1).Value = dept Then

targetIndex = targetIndex + 1
targetSheet.Rows(targetIndex).Value = _
sourceSheet.Rows(sourceIndex).Value

End If

Next

Application.ScreenUpdating = True

End Sub
Function GetSheet(sheetsname As String) As Worksheet
On Error Resume Next
Set GetSheet = Worksheets(sheetsname)
If Err.Number = 0 Then
GetSheet.Cells.Clear
Else
Set GetSheet = Worksheets.Add
GetSheet.Name = sheetsname
End If
On Error GoTo 0
End Function


this should be easy enough. screen updating speeds things up quite a bit
we simple check each row to see if the cell in A matches teh dept, then we
copy it. we keep a record of which is the nest row to update.

Its probably faster to use 'FIND' so I'll add that routine in my next mail
shortly


"Tim" wrote:

Hi folks,

I need a help on Excel macro. I have a spreadsheet which called sheet1 and
has thousands of records and group by departments. I want to create a macro
which can move the same departments records to the new sheet and rename the
sheet to the department name. Could anyone show me the code? Any help will
be appreciated?

Thanks in advance.

Tim.