Tony, I'm not quite sure what you want it to do. Can you please clarify?
Email me @
--
Charles Chickering

"A good example is twice the value of good advice."


"TonyD" wrote:

I guess it would help if I sent you the updated code:

Private Sub CommandButton2_Click()
Dim wsHR As Worksheet
Dim wsPh As Worksheet
Dim lRow As Long 'Last Row
Dim cnt As Long
Dim pDept 'Previous department
Dim iRow As Long 'Insert Row for Phone List sheet
'Change the following 2 lines to reflect the worksheets where the data is
Set wsHR = Workbooks("HR test.xls").Worksheets("Data")
Set wsPh = Workbooks("HR test.xls").Worksheets("Phone List")
With wsHR
lRow = .Range("A8").End(xlDown).Row
iRow = 1
For cnt = 2 To lRow
If .Range("A" & cnt) < pDept Then
' wsPh.Range("A" & iRow + 1) = .Range("A" & cnt)
wsPh.Range("A" & iRow + 2) = .Range("a" & cnt) & _
" " & .Range("b" & cnt)
wsPh.Range("B" & iRow + 2) = .Range("g" & cnt)
iRow = iRow + 1
pDept = .Range("A" & cnt)
Else
wsPh.Range("A" & iRow) = .Range("a" & cnt) & _
" " & .Range("b" & cnt)
wsPh.Range("B" & iRow) = .Range("g" & cnt)
iRow = iRow + 1
End If
Next
End With

End Sub

"TonyD" wrote:

Charles, I made some minor modifications which have helped me to populate the
first name" "last name in column A and phone number in column "B". I would
like to now change the single First Name as replace it with the Dept Name
each time it changes preceded by a blank line followed by all employees in
that Dept. I also want to not pick up the First Name, Last Name, Phone #
headers from row 6 of the Source worksheet and start with the first/last name
from row 7. Here is what it looks like now:

First Name Last Name Phone #
Tony Dungate 555-440-4177
etc.

I would like it to look like this:

Acctg
Tony Davies 555-440-4177

Payroll
Sean Davies 555-440-4178
Wendy Davies 555-440-4179
etc.

Thanks for your help, so far it has helped me out considerably.

"Charles Chickering" wrote:

Tony, here's one solution assuming that the hr database is sorted by dept.
number:
Sub HRtoPhone()
Dim wsHR As Worksheet
Dim wsPh As Worksheet
Dim lRow As Long 'Last Row
Dim cnt As Long
Dim pDept 'Previous department
Dim iRow As Long 'Insert Row for Phone List sheet
'Change the following 2 lines to reflect the worksheets where the data is
Set wsHR = Workbooks("HR Data.xls").Worksheets("Data")
Set wsPh = Workbooks("PhoneList.xls").Worksheets("List")
With wsHR
lRow = .Range("A2").End(xlDown).Row
iRow = 1
For cnt = 2 to lRow
If .Range("A" & cnt) < pDept Then
wsPh.Range("A" & iRow + 1) = .Range("A" & cnt)
wsPh.Range("A" & iRow + 2) = .Range("B" & cnt) & _
" " & .Range("C" & cnt)
wsPh.Range("B" & iRow + 2) = .Range("E" & cnt)
iRow = iRow + 3
pDept = .Range("A" & cnt)
Else
wsPh.Range("A" & iRow) = .Range("B" & cnt) & _
" " & .Range("C" & cnt)
wsPh.Range("B" & iRow) = .Range("E" & cnt)
iRow = iRow + 1
End If
Next
End With
End Sub

Note: Not tested, post back or email me @ if you have
problems.
--
Charles Chickering

"A good example is twice the value of good advice."


"TonyD" wrote:

I am trying to take data from an excel database (HR Database) and create a
phone list by department in an existing worksheet (By First Name). I have to
use the Dept name as the header for each section followed by each person's
name combined as First&Last in column A followed by their phone number in
column B. For each new person in the same dept I want to put in the next row
until a blank line is met wher I will have a blank row in the Phone List
followed by the next Dept name and then their associated staff and phone
numbers. Since I very new to VBA, I could use a little hrlp getting started.


HR Database (worksheet name)

"A" "B" "C" "D" "E"
Dept First Last Title
Phone
-------- ------ ---- -----
-------
Payroll Wendy Davies Admin Assistant 555-440-4100
Payroll Tony Davies Analyst 555-440-5200
Acctg Sean Davies Accountant 555-440-6300
---------------------------------------------------------------------------------
By First Name (worksheet name)
(Space)
Payroll (Cell a8)
Wendy Davies(Cell a9) 555-440-4100(Cell b9)
Tony Davies 555-440-5200
(space)
Acctg (Cell a?)
Sean Davies(Cell a?? 555-440-6200(Cell b?)