View Single Post
  #3   Report Post  
Posted to microsoft.public.excel.misc
JLatham JLatham is offline
external usenet poster
 
Posts: 3,365
Default Excel Macro Looping Helps

ChristopherTri has offered up a viable solution and you may want to just use
it if there are not many teams involved. But if there are a lot of teams
involved, or if you're going to have to do this often then this code may help
you. Note that if you run this routine twice with the same information on
the Summary Page, then it is going to end up on the team sheets twice (and
again for each time you run it).

If you are going to have information added to the data on the Summary Page
and then need to move that to the existing team sheets, easiest thing to do
is first delete all existing team sheets and 'rebuild' them using this
process. It will even create the sheets for you as long as the entries in
column E are valid to use as sheet names. There are some Constants you can
change if your sheet layout changes, I think I've given them 'intuitive'
names, so changing them shouldn't be too difficult, I hope.

Sub MoveTeamEntries()
Const FirstRowWithTeamData = 2 ' row 1 is header row
Const TeamColumn = "E" ' column with team ID/Sheet names
Const SourceSheet = "Summary Page"
Const FirstColToCopy = "A"
Const LastColToCopy = "V"

Dim lastDataRow As Long
Dim destSheet As String ' hold name of destination sheeet
Dim destRow As Long ' row on dest sheet to put data into
Dim rowOffset As Long ' pointer to data
Dim whatToCopy As Range
Dim whereToPaste As Range
Dim testPageValue As Variant 'use to test for page presence

'find last used row on Summary Page
lastDataRow = Worksheets(SourceSheet).Range(TeamColumn _
& Rows.Count).End(xlUp).Row
'select Summary Page and cell at top of team list
Worksheets(SourceSheet).Select
Range(TeamColumn & "1").Select
'turn off screen updating for speed
Application.ScreenUpdating = False
For rowOffset = (FirstRowWithTeamData - 1) To lastDataRow - 1
'don't do anything if cell is empty
If Not IsEmpty(ActiveCell.Offset(rowOffset, 0)) Then
' create name of sheet to seek
destSheet = Trim(ActiveCell.Offset(rowOffset, 0))
If Len(destSheet) 0 Then ' have a name!
Set whatToCopy = Worksheets(SourceSheet). _
Range(ActiveSheet.Range(FirstColToCopy & rowOffset + 1) _
.Address & ":" & _
ActiveSheet.Range(LastColToCopy & rowOffset + 1).Address)
'test if destination sheet exists
On Error Resume Next
' any cell will do
testPageValue = Worksheets(destSheet).Range("A1")
If Err < 0 Then
'page does not exist, create it
Err.Clear
On Error GoTo 0
Worksheets.Add ' add sheet, it gets selected
'can fail if destSheet is not a valid sheet name!
ActiveSheet.Name = destSheet ' name it
Worksheets(SourceSheet).Select ' back to proper sheet
End If
On Error GoTo 0
destRow = Worksheets(destSheet).Range(TeamColumn & _
Rows.Count).End(xlUp).Row
If Not (IsEmpty(Worksheets(destSheet).Range(TeamColumn & _
destRow))) Then
'only on new, or empty sheets
destRow = destRow + 1
End If
Set whereToPaste = Worksheets(destSheet).Range( _
Range(FirstColToCopy & destRow).Address & ":" & _
Range(LastColToCopy & destRow).Address)
whereToPaste.Value = whatToCopy.Value
End If ' test for sheet name
End If ' test for empty cell
Next ' rowOffset loop
Application.ScreenUpdating = True

End Sub


"Jurassien" wrote:

Hello,

I desperately need help on creating a macro script that will be moving data
from the summary sheet within a workbook to the next sheet based on team ID
(column E).

Something like if cell E3 = 000 then copy the entire row to sheet 000 else
look for another Team ID within the same column (E) and do the same process
(sheet 001) so on.


I currently do it manually and it seems to be very time consuming. I was
wondering if the script below can be changed to fit what I am trying to
accomplish. Any helps would be greatly appreciated.

Sub DoCopy()
Dim szRange As String
szRange = "E1:V200"

Worksheets("Summary Page").Range(szRange).Copy
Destination:=Worksheets("Team-000").Range(szRange)
Worksheets("Summary Page").Range(szRange).Copy
Destination:=Worksheets("Team-001").Range(szRange)
Worksheets("Summary Page").Range(szRange).Copy
Destination:=Worksheets("Team-002").Range(szRange)

End Sub



Thanks,