Create worksheets for each matching values in Column?

[Kobayashi]

I have one worksheet with multiple columns. In one of these columns (C
I have a number of currencies. However, both the number of rows an
number of currencies can change from day to day. I would like to b
able to create additional worksheets for each of the relevan
currencies and cut the data from workseet 1 into each of the individua
currency sheets?

For example:

Column B has 4 rows.

Row 1 has value of USD
Row 2 has value of EUR
Row 3 has value of EUR
Row 4 has value of FRF
etc.....

After running the procedure I should now have three workseets, one fo
USD with one row, one for EUR with two rows and one for FRF with on
row.

Any pointers in the right direction would be appreciated.

Regards,

Adria

 

[Bob Phillips]

Hi Adrian,

Here is a shot


Sub MyCurrencies()
Dim cNumRows As Long
Dim i As Long
Dim cNextRow As Long
Dim sh As Worksheet

With ActiveSheet
cNumRows = .Cells(Rows.Count, "C").End(xlUp).Row
For i = 1 To cNumRows
If Not SheetExists(.Cells(i, "C").Value) Then
Worksheets.Add.Name = .Cells(i, "C").Value
Worksheets(.Cells(i, "C").Value).Cells(1, "A").Value =
..Cells(i, "C").Value
Else
Set sh = Worksheets(.Cells(i, "C").Value)
cNextRow = sh.Cells(Rows.Count, "A").End(xlUp).Row + 1
sh.Cells(cNextRow, "A").Value = .Cells(i, "C").Value
End If
Next i
End With

End Sub

'-----------------------------------------------------------------
Function SheetExists(sh As String, _
Optional wb As Workbook) As Boolean
'-----------------------------------------------------------------
Dim oWs As Worksheet
If wb Is Nothing Then Set wb = ActiveWorkbook
On Error Resume Next
SheetExists = CBool(Not wb.Worksheets(sh) Is Nothing)
On Error GoTo 0
End Function



--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

 

[Kobayashi]

Bob, this is fantastic! As always, many thanks indeed! I've lost coun
of the number of times either yourself or Tom (Oglivy) have helped m
enormously!

However, one very minor point. I want to copy the entirerow and no
just the currency value into the new worksheets? I'm trying to adap
your code now to accomodate but if you are online and can help the
that would also be appreciated!

Many thanks indeed!

Adria

 

[Bob Phillips]

Adrian ,

This changed version of MyCurrencies procedure does it (I hope!)

Sub MyCurrencies()
Dim cNumRows As Long
Dim i As Long
Dim cNextRow As Long
Dim sh As Worksheet

With ActiveSheet
cNumRows = .Cells(Rows.Count, "C").End(xlUp).Row
For i = 1 To cNumRows
If Not SheetExists(.Cells(i, "C").Value) Then
Worksheets.Add.Name = .Cells(i, "C").Value
.Cells(i, "C").EntireRow.Copy Worksheets(.Cells(i,
"C").Value).Cells(1, "A")
Else
Set sh = Worksheets(.Cells(i, "C").Value)
cNextRow = sh.Cells(Rows.Count, "A").End(xlUp).Row + 1
.Cells(i, "C").EntireRow.Copy sh.Cells(cNextRow, "A")
End If
Next i
End With

End Sub

--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

 

[Kobayashi]

Bob,

Again, many thanks for the very speedy response! In the interim I'v
actually surprised myself and amended the code which seems to work
Basically, I just replaces some of the 'cells' references to that o
'rows'. However, I'd be interested in your opinion and if you recomen
me replacing it with what you have just recently submitted then
certainly shall?

I've also changed the With reference to a variable I'm already declare
in my module.

Dim cNumRows As Long
Dim i As Long
Dim cNextRow As Long
Dim sh As Worksheet

With Newsheet
cNumRows = .Cells(Rows.Count, "C").End(xlUp).Row
For i = 2 To cNumRows
If Not SheetExists(.Cells(i, "C").Value) Then
Worksheets.Add.Name = .Cells(i, "C").Value
Worksheets(.Cells(i, "C").Value).Rows(1).Value = _
.Cells(i, "C").EntireRow.Value
Else
Set sh = Worksheets(.Cells(i, "C").Value)
cNextRow = sh.Cells(Rows.Count, "A").End(xlUp).Row + 1
sh.Rows(cNextRow).Value = .Cells(i, "C").EntireRow.Value
End If
Next i
End With

End Sub

Many thanks,

Adria

 

[Bob Phillips]

Adrian,

This doesn't seem to work for me. It creates all of the sheets but nothing
is copied across. The statements

..Cells(i, "C").EntireRow.Value

seems to return a blank, because it is trying to get the value of a whole
row.

--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

 

[Kobayashi]

Bob,

Strange? I couldn't get the ..cells reference working on your firs
submission so changed it to worksheets.cells......., which seemed t
work? Never mind, it is working which is the main thing and I've save
your amendments also just in case it goes wonky on me!

Thanks again,

Adria

 

[Bob Phillips]

Right, as you say, if it works!

--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)