Transposition for a 3,000 provider directory worksheet

[AetBridge]

I have a provider directory with about 3,000 physicians that is set u
as a vertical list in excel. Each physician is set up as:

Physician's name(A)
Hospital(A) (only half of the listings have this line)
Address(A)
City, State, Zip(A)
Phone(A)
Provider ID #(A)
Gender(A)
Panal Status(A)

Physician's name(B)
Hospital(B) (only half of the listings have this line)
Address(B)
City, State, Zip(B)
Phone(B)
Provider ID #(B)
Gender(B)
Panal Status(B)


I need to transpose all of this information to get all of th
categories into columns like:

nameA HospitalA AddressA City,St,ZipA PhoneA ProviderA etc.
nameB HospitalA AddressB City,St,ZipB PhoneB ProviderB etc.


Is there a way to do all of these at once instead of manually doin
them?

The major problem that I see is that 1/2 of the 3000 listings have
lines and the other have 8 lines because not all of them have
hospital. However, every listing does end with the words "panal staus
on the last line (if that helps at all).

Can anyone assist me with this problem?
Thanks,
Bridget U

 

[Frank Kabel]

Hi
not fully tested but try the following macro
Sub transpose_data()
Dim s_wks As Worksheet
Dim t_wks As Worksheet
Dim s_row As Long
Dim t_row As Long
Dim t_col As Integer
Dim lastrow As Long
application.screenupdating=false
Set s_wks = ActiveWorkbook.Worksheets("Tabelle1")
Set t_wks = ActiveWorkbook.Worksheets("Tabelle2")
lastrow = s_wks.Cells(Rows.Count, "A").End(xlUp).row
t_row = 1
t_col = 1

For s_row = 1 To lastrow
Select Case t_col
Case 2
If InStr(s_wks.Cells(s_row + 5, 1).Value, "Panal Status") > 0
Then
t_col = t_col + 1
End If
Case 9
t_col = 1
t_row = t_row + 1
End Select
t_wks.Cells(t_row, t_col).Value = s_wks.Cells(s_row, 1).Value
t_col = t_col + 1

Next s_row
application.screenupdating=True
End Sub


This works only, if you have no blank lines in between!

 

[Max]

FWIW, if the data could be separated into 2 sheets:
one for 7 lines and the other for 8 lines
then this could come-in handy ..

Data structure is nicely in groups of:
7 lines + 1 blank line in-between in col A, row1 down

Put in B1: =OFFSET($A$1,ROW(1:1)*8-8+COLUMN(B:B)-2,)
Copy across 7 cols to H1, then down until zeros appear

Data structure is nicely in groups of:
8 lines + 1 blank line in-between in col A, row1 down

Put in B1: =OFFSET($A$1,ROW(1:1)*9-9+COLUMN(B:B)-2,)
Copy across 8 cols to I1, then down until zeros appear

 

[Alan Beban]

If the functions in the freely downloadable file at
http://home.pacbell.net are available to your workbook:

Sub BBB()
Dim rng As Range, arr, k As Integer, n As Integer
Set rng = Range("A1:A24000")
numdocs = 3000
k = 1
Do Until k = numdocs + 1
If Not rng(8 * k, 1).Value Like "*Panal Status*" Then
rng(8 * k - 5, 1).EntireRow.Insert
rng(8 * k - 5, 1).Value = "None"
End If
k = k + 1
Loop
arr = ArrayReshape(Range("A1:A" & numdocs * 8), numdocs, 8)
Range("B1:I" & numdocs).Value = arr
End Sub

Alan Beban

 

[Max]

Marvellous sub, Frank !

 

[Harlan Grove]

I have a provider directory with about 3,000 physicians that is set up
as a vertical list in excel. Each physician is set up as:

Physician's name(A)
Hospital(A) (only half of the listings have this line)
Address(A)
City, State, Zip(A)
Phone(A)
Provider ID #(A)
Gender(A)
Panal Status(A)

Physician's name(B)
Hospital(B) (only half of the listings have this line)
Address(B)
City, State, Zip(B)
Phone(B)
Provider ID #(B)
Gender(B)
Panal Status(B)


I need to transpose all of this information to get all of the
categories into columns like:

nameA HospitalA AddressA City,St,ZipA PhoneA ProviderA etc.
nameB HospitalA AddressB City,St,ZipB PhoneB ProviderB etc.

Is there a way to do all of these at once instead of manually doing
them?

The major problem that I see is that 1/2 of the 3000 listings have 7
lines and the other have 8 lines because not all of them have a
hospital. However, every listing does end with the words "panal staus"
on the last line (if that helps at all).

For the heck of it, a worksheet formula approach. If your original range of
records *including* a blank cell below the final record were named OrigRecs, and
the physician's name for the first record would be in cell A3 of the active
worksheet (which needn't be the same as the one containing OrigRecs), use these
formulas.

A3:
=INDEX(OrigRecs,1)

B3:
=IF(TRIM(INDEX(OrigRecs,9))="",INDEX(OrigRecs,2),"")

C3:H3 [array formula]:
=INDEX(OrigRecs,{2,3,4,5,6,7}+($B3<>""))

A4:
=INDEX(OrigRecs,COUNTA($A$3:$H3)-COUNTIF($B$3:$B3,"<*")+ROWS($A$3:$H3)+1)

B4:
=IF(TRIM(INDEX(OrigRecs,COUNTA($A$3:$H3)-COUNTIF($B$3:$B3,"<*")
+ROWS($A$3:$H3)+9))="",INDEX(OrigRecs,COUNTA($A$3:$H3)-COUNTIF($B$3:$B3,"<*")
+ROWS($A$3:$H3)+2),"")

C4:H4 [array formula]:
=INDEX(OrigRecs,COUNTA($A$3:$H3)-COUNTIF($B$3:$B3,"<*")+ROWS($A$3:$H3)
+{2,3,4,5,6,7}+($B4<>""))

Select A4:H4 and fill down until the formulas return #REF! errors. Clear the
cells returning #REF!, select the remaining cells, Edit > Copy, and Edit > Paste
Special as values.

 

[Harlan Grove]

FTHOI, yet another macro.

Sub foo()
Const INCHOSPFLDS As Long = 8

Dim orecs As Range, src As Range, dest As Range
Dim k As Long, n As Long

If Not TypeOf Selection Is Range Then Exit Sub

Set orecs = Selection
n = orecs.Rows.Count

If Trim(orecs.Cells(n, 1).Value) <> "" Then
n = n + 1
Set orecs = orecs.Resize(n, 1)
End If

k = 0

Do
Set src = orecs.Offset(k, 0).Resize(INCHOSPFLDS, 1)

If dest Is Nothing Then
Set dest = orecs.Resize(1, INCHOSPFLDS)

Else
Set dest = dest.Offset(1, 0)

End If

dest.Value = Application.WorksheetFunction.Transpose(src.Value)

If Trim(dest.Cells(1, INCHOSPFLDS).Value) = "" Then
dest.Offset(0, 1).Resize(1, INCHOSPFLDS - 2).Cut _
Destination:=dest.Offset(0, 2).Resize(1, INCHOSPFLDS - 2)

k = k + INCHOSPFLDS

Else
k = k + INCHOSPFLDS + 1

End If

Loop While k < n

orecs.Offset(dest.Row - orecs.Row + 1, 0).Resize(n - dest.Row - 1, 1).Clear

Range(orecs.Cells(1, 1), dest.Cells(1, INCHOSPFLDS)).Select

End Sub