complicated question for copying ranges to new sheets

[Annette]

If I have a list of 20 standard offices on sheet 1, and on sheet 2, there is
a list of orders for some of the offices (the offices are listed in col. A
and repeated for each item down through each row.

The items are alphabetically by office on sheet 2, and what I'd like to do
is move any information found that matches an office name on sheet 1, copy
to the next available sheet. Then do the same to the next set of information
that qualifies.

FOR EXAMPLE:
Sheet 1 contains:

chicago
new york
san fransico

Sheet 2:
chi 3 bats
chi 5 balls
chi 2 gloves
san 1glove
san 1 ball
===============
What the macro would do is 'copy' the information on sheet 2 to two
different sheets (3 and 4):

Sheet 3:
chicago 3 bats
chicago 5 balls
chicago 2 gloves

Sheet 4:
san fransico 1 glove
san fransico 1 ball


It might be easier to just split information into separate sheets with any
care to what is on sheet 1 ... either way ... would be most helpful.

Annette

 

[John Williams]

Sub Macro1()
Dim iRow, endRow As Integer

Worksheets("Sheet1").Select
Range("A1").Select

'For each office listed in Sheet1 copy the orders listed in Sheet2

endRow = Cells(Rows.Count, ActiveCell.Column).End(xlUp).Row
For iRow = 1 To endRow
Worksheets("Sheet1").Select
Call copyOrders(Cells(iRow, 1).Value, "Sheet2")
Next

End Sub

Sub copyOrders(office As String, ordersSheet As String)
Dim officeSheet
Dim ordersRange As Range
Static iRow As Integer 'Retain row number where
office search ended
Dim lastOrdersRow, startRow, endRow As Long

Sheets(ordersSheet).Select
Range("A1").Select

'Look through the orders sheet and determine the start and end
rows for the orders relating to
'the current office. This allows us to copy and paste the block
of orders in one operation
'instead of individually.

startRow = 0
endRow = 0
iRow = iRow + 1
lastOrdersRow = Cells(Rows.Count, ActiveCell.Column).End(xlUp).Row
While iRow <= lastOrdersRow + 1 And endRow = 0
If Cells(iRow, 1) = office And startRow = 0 Then
startRow = iRow
ElseIf Cells(iRow, 1) <> office And startRow <> 0 Then
endRow = iRow - 1
Else
iRow = iRow + 1
End If
Wend
iRow = iRow - 1

'If there are any orders for this office

If endRow <> 0 Then

'Create a new worksheet if it doesn't exist

If worksheetExists(office) Then
Set officeSheet = Sheets(office)
Else
Set officeSheet = Sheets.Add
officeSheet.Name = office 'Name sheet as the office
End If

'Copy the office name and related orders to the office sheet.
'This assumes that the office name is in column A, and the
orders are in column B

Sheets(ordersSheet).Select
Set ordersRange = Range(Cells(startRow, 1), Cells(endRow, 2))
ordersRange.Select
Selection.Copy
Sheets(office).Select
ActiveSheet.Paste
Application.CutCopyMode = False

End If

End Sub

Function worksheetExists(WSName As String, Optional WB As Workbook) As
Boolean
On Error Resume Next
worksheetExists = CBool(Len(IIf(WB Is Nothing, ActiveWorkbook,
WB).Worksheets(WSName).Name))
End Function

 

[Annette]

This works so well ... I really like this ... thank you for your help!

 

[John Williams]

This works so well ... I really like this ... thank you for your help!

You're welcome! These little technical questions are a great way to
learn Excel VBA. A tip - use the macro recorder to manually do what
you require and have a look at the VBA generated