Transposing selected column headings

[Guest]

Hi

In Excel 2000 I have a spreadsheet with a list of staff names in column A. Columns B to P are head with different item types for which they can sign. Under these headers is either a value or text entry. I have inserted a blank row
for each header that contains an entry other than 0 or "N". Item and Amount are additional column headers.

Name Invoices Petty Cash Cheques Holiday Forms Mat Leave Item Amt
G Smith £1000 £100 0 Y N


J Brown 0 0 £100 Y Y


Jeff Black £500 £500 0 N N

Etc

Now I want to place the headers, where the entry is anything but 0 and 'N', in the blank rows starting in the next column Q headed Item and the entry in the cell below in the column headed Amount to give:

Name Invoices Petty Cash Cheques Holiday Forms Mat Leave Item Amt
G Smith £1000 £100 0 Y N Invoices£1000
Petty Ca £100
Holiday F Y
J Brown 0 0 £100 Y Y Cheques £100
Holiday F Y
Mat Leave Y
J Black £500 £500 0 N N Invoices £500
Petty Ca £500
Etc

 

[Bob Phillips]

Sub Reformat()
Dim cLastRow As Long
Dim cLastCol As Long
Dim i As Long, j As Long, k As Long

'first get rid of the useless blank lines
cLastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = cLastRow To 2 Step -1
If Cells(i, "A") = "" Then
Cells(i, "A").EntireRow.Delete
End If
Next i

'then re-jig the data
cLastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = cLastRow To 2 Step -1
cLastCol = Cells(i, Columns.Count).End(xlToLeft).Column
k = 0
For j = 2 To cLastCol
If Cells(i, j).Value <> 0 And _
UCase(Cells(i, j).Value <> "N") Then
If k > 0 Then
Cells(i + k, "A").EntireRow.Insert
End If
Cells(i + k, "Q").Value = Cells(1, j).Value
Cells(i + k, "R").Value = Cells(i, j).Value
k = k + 1
End If
Next j
Next i

End Sub


--

HTH

RP
(remove nothere from the email address if mailing direct)


A. Columns B to P are head with different item types for which they can
sign. Under these headers is either a value or text entry. I have inserted
a blank rowAmount are additional column headers.

Name Invoices Petty Cash Cheques Holiday Forms Mat Leave Item Amt
G Smith £1000 £100 0 Y N


J Brown 0 0 £100 Y Y


Jeff Black £500 £500 0 N N

Etc

'N', in the blank rows starting in the next column Q headed Item and the
entry in the cell below in the column headed Amount to give:

 

[Tom Ogilvy]

Sub Gar3th()
Dim rng As Range, rng1 As Range
Dim rng2 As Range, cell As Range
Dim i As Long, j As Long
Set rng = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp))
Set rng = rng.SpecialCells(xlConstants)
For Each cell In rng
i = 0
For j = 2 To 16
Set rng1 = Cells(cell.Row, j)
Set rng2 = Cells(1, j)
If rng1.Text <> "" And rng1.Text <> "0" And _
UCase(rng1.Text) <> "N" Then
cell.Offset(i, 16).Value = rng2.Value
cell.Offset(i, 17).Value = rng1.Value
i = i + 1
End If
Next
Next

End Sub


A. Columns B to P are head with different item types for which they can
sign. Under these headers is either a value or text entry. I have inserted
a blank rowAmount are additional column headers.

Name Invoices Petty Cash Cheques Holiday Forms Mat Leave Item Amt
G Smith £1000 £100 0 Y N


J Brown 0 0 £100 Y Y


Jeff Black £500 £500 0 N N

Etc

'N', in the blank rows starting in the next column Q headed Item and the
entry in the cell below in the column headed Amount to give:

 

[Guest]

Hi Bob

Thankyou very much for this it appears to work well. Out of interest the
comment on the first bit says 'first get rid of the useless blank lines.
However, if I run this on a spreadsheet with blank lines it inserts
additional blanks. If I run it on a sheet without blank lines between the
names it puts the correct number in.

Again my colleague is extremely grateful having saved many days of work and
helping the efficiency of the NHS.

 

[Guest]

Hi Tom

Thanks for the code it worked very well.

Regards

Gareth

 

[Bob Phillips]

It shouldn't make any difference, as the whole point of the first code
segment is to remove the blanks (I couldn't determine whether there would be
one, or one per authority, so I decided to remove that variable). Therefore,
if there are none, nothing happens, if there it removes them, either way, it
starts from the same base point.

It may be important, as I see you say that both mine and Tom's version
works. As I said, I couldn't determine your blank rows, and if there is just
1 blank row between them, Tom's solution gives a different result to mine.
Only you can determine which is correct, but just to put you on notice.

Regards

Bob

 

[Tom Ogilvy]

He has been posting for a couple of days. His initial post asked for code
to put in the correct number of blank lines. He received that code from
Edward Tam as I recall and so my assumption was he had the correct number of
lines and so I didn't try to do more than he asked.

 

[Bob Phillips]

Didn't see that post Tom, and couldn't work it out from what was given.

Bob

 

[Guest]

Hi Bob

Thanks for the response. The initial data on the sheet does not have any
blank lines between the authority so when I run your code on this it appears
to insert the correct number of lines and the headings. Tom's works after I
have used Edwin Tam's code to insert the blank lines first.

Anyway once again thanks

Gareth

 

[Bob Phillips]

Gareth,

As was pointed out, Tom was aware of Edwin's code, I was not, so he took
that into account, I produced a more generic solution.

Bob