Terry,

First select your data table, without the formulas at the bottom or the
merged cells at the top. The macro was written to automatically select the
range but it would be better if you did it manually - or you could insert a
blank row below the merged headings and above the formula rows. Your
choice - the code for both ways is in the version below, and you can comment
out the current one (where you need to select the table) and uncomment the
other (but you will need to add the blank rows above and below your table).

Also, I have added code to check for blank headers. In your sample, BM3 on
'7th Floor' is blank, but should be filled in. This version will find that
and give a message saying "Fill it in", then quit to allow you to prior to
proceeding.

With those changes, it works great.

HTH,
Bernie
MS Excel MVP

Sub MakeTable3()
Dim myCell As Range
Dim newSheet As Worksheet
Dim mySheet As Worksheet
Dim i As Long
Dim j As Integer
Dim k As Long
Dim l As Integer
Dim mySelection As Range
Dim RowFields As Integer
Dim myCalc As XlCalculation

Set mySheet = ActiveSheet
Set mySelection = Selection 'Comment this one out and
'Uncomment the next line if you've added blank rows
'Set mySelection = ActiveCell.CurrentRegion
If Application.WorksheetFunction.CountBlank( _
Selection.Rows(1)) 0 Then
MsgBox "Cell(s) " & Selection.Rows(1).SpecialCells( _
xlCellTypeBlanks).Address(False, False) & _
" is (are) blank but should be filled in." & Chr(10) & _
Chr(10) & "Fill it/them in and try again."
Exit Sub
End If
RowFields = Application.InputBox( _
"How many left-most columns to treat as row fields?", _
"CrossTab to DataBase Helper", 1, , , , , 1)
On Error Resume Next
With Application
.DisplayAlerts = False
myCalc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
Worksheets("New Database").Delete
Application.DisplayAlerts = True
Set newSheet = Worksheets.Add
newSheet.Name = "New Database"
mySheet.Activate
i = 1
For j = mySelection(1).Row + 1 To _
mySelection(mySelection.Cells.Count).Row
For k = mySelection(1).Column + RowFields To _
mySelection(mySelection.Cells.Count).Column
If mySheet.Cells(j, k).Value < "" Then
For l = 1 To RowFields
newSheet.Cells(i, l).Value = _
Cells(j, mySelection(l).Column).Value
Next l
newSheet.Cells(i, RowFields + 1).Value = _
Cells(mySelection(1).Row, k).Value
newSheet.Cells(i, RowFields + 2).Value = _
Cells(j, k).Value
i = i + 1
End If
Next k
Next j
With Application
.EnableEvents = False
.DisplayAlerts = True
.Calculation = myCalc
.ScreenUpdating = True
End With

End Sub


"twaccess " wrote in message
...
I give up I'm afraid. There are some merged cells in the two rows above
the header row, but I can't see anything else though.

Its not too sensitive, but I've mangled it up anyway without affecting
the spreadsheets performance.

I also find that sometimes I get a completely blank result as well.

Thanks & Regards

Attachment filename: mangled crosstab.xls
Download attachment:
http://www.excelforum.com/attachment.php?postid=497484
---
Message posted from http://www.ExcelForum.com/