Crosstab to Database VBA

  • Thread starter Thread starter twaccess
  • Start date Start date
T

twaccess

I receive quite often large spreadsheets which have been lovingl
created which are difficult to manipulate to create alternative report
using Pivot tables or Sumifs etc...

I wonder if anyone has in their toolbox a routine which takes such
crosstab report and crawls through it and creating from it a tabula
database. Such a routine would calculate how long the X and Y axes ar
of the report and loop through each column and row to capture eac
value and create a line of data fields.

Attached is a very small example of what I am trying to achieve i
terms of before and after if it helps to explain what I'm trying t
do.

I would appreciate any help thats available.

Thanks


Terr

Attachment filename: crosstab to database format.xls
Download attachment: http://www.excelforum.com/attachment.php?postid=49504
 
Terry,

If you mean

Header1 Header2
Row1 Val1 Val2
Row2 Val3

converted to

Row1 Header1 Val1
Row1 Header2 Val2
Row2 Header2 Val3

then select your Crosstab table and run the macro below.

HTH,
Bernie
MS Excel MVP

Sub MakeDataTableFromCrossTabTable()
'By Bernie Deitrick
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 mySelection As Range

Set mySheet = ActiveSheet
Set mySelection = Selection
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("New Database").Delete
Set newSheet = Worksheets.Add
newSheet.Name = "New Database"
mySheet.Activate
i = 1
For j = mySelection(1).Column + 1 To
mySelection(mySelection.Cells.Count).Column
For k = mySelection(1).Row + 1 To mySelection(mySelection.Cells.Count).Row
If mySheet.Cells(k, j).Value <> "" Then
newSheet.Cells(i, 1).Value = Cells(mySelection(1).Row, j).Value
newSheet.Cells(i, 2).Value = Cells(k, mySelection(1).Column).Value
newSheet.Cells(i, 3).Value = Cells(k, j).Value
i = i + 1
End If
Next k
Next j

Application.DisplayAlerts = True

End Sub
 
Absolutely sublime piece of code.

You have saved me many hours of cutting and pasting ! I shall neve
groan with dismay again when I see a huge crosstab spreadsheet again !

Many thanks Bernie
 
Oh no, just when I thought it was safe to go back into Crosstabs. I'v
just been given the mother of all crosstabs.

This one has 6 (yes, six) row fields, 1 header field(with 50 entrie
across the top of the spreadsheet) and of course 1 value field.

Is it possible please, to vary the code so that it can cope with thes
extra row fields ?

Thanks in anticipation
 
Do you mean that you want the first 6 cells of each row, then the cell from
the column header (the header field), then the value?

This:

Head1 Head2 Head3 Head4 Head5 Head6 Head7 Head8 Head9
Val1 Val2 Val3 Val4 Val5 Val6 Val7 Val8 Val9
Val10 Val11 Val12 Val13 Val14 Val15 Val16 Val17 Val18

Converted to:
Val1 Val2 Val3 Val4 Val5 Val6 Head7 Val7
Val1 Val2 Val3 Val4 Val5 Val6 Head8 Val8
Val1 Val2 Val3 Val4 Val5 Val6 Head9 Val9
Val10 Val11 Val12 Val13 Val14 Val15 Head7 Val16
Val10 Val11 Val12 Val13 Val14 Val15 Head8 Val17
Val10 Val11 Val12 Val13 Val14 Val15 Head9 Val18

Yes?

HTH,
Bernie
MS Excel MVP
 
Try the macro below, and enter a 6 when the inputbox comes up.

Let me know if that's what you wanted.

HTH,
Bernie
MS Excel MVP

Sub MakeTable2()
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

Set mySheet = ActiveSheet
Set mySelection = ActiveCell.CurrentRegion
RowFields = Application.InputBox( _
"How many left-most columns to treat as row fields?", _
"CrossTab to DataBase Helper", 1, , , , , 1)
On Error Resume Next
Application.DisplayAlerts = False
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

End Sub
 
Thanks very much for this. It worked very well on the small test file
but when I tried it on an actual large crosstab I got an unpredictabl
response.

The row fields all appeared in the 6 left most columns as require
along with the values in the 8th column. But the header fields didn
appear at all in the 7th column, but some appeared in the cells abov
the values.

I'm checking the original crosstab to see if there's anythin
corrupting the process like merged cells etc..

Thank
 
Terry,

Merged cells in the header row would be my guess. Check for hidden rows and
columns as well.

If you can't figure it out, send me a copy of your datatable, if it isn't
too sensitive, or a heavily-mangled copy of it if it is.

HTH,
Bernie
MS Excel MVP
 
I give up I'm afraid. There are some merged cells in the two rows abov
the header row, but I can't see anything else though.

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

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

Thanks & Regard

Attachment filename: mangled crosstab.xls
Download attachment: http://www.excelforum.com/attachment.php?postid=49748
 
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
 
Bernie

This works sweet as a nut !

I've left the programme as it is as I'd rather be able to use it on an
cross-tab report without having to worry about merged cells above th
headers etc..

This particular one is probably the worst cross-tab I've ever seen a
it is so large that it is almost unusable even in its present state
With your routine, I have now converted 9 of these cross-tabs int
databases from which I'll do my pivot table reports etc..

As a point of interest, if you wanted to finesse this programme, yo
could add a feature where you prompt the user to select the top lef
corner of the crosstab and then use vb to crawl along the header an
row fields to determine the overall size of the crosstab without havin
the user to select the whole crosstab first. But, I'm very happy wit
this programme as it stands and it now has a permanent place in m
toolbox. (Hmmm, actually on second thoughts, this could tend to includ
formulas at the bottom which we dont want to do, so probably best t
leave it as it is)


Thanks and Regard
 
Terry,

There are as many variations on this theme as there are people who produce
crosstab data tables. The best idea is to have a good basic routine, and
then modify it to fit the particulars of the data table or to modify your
data table to fit the particulars of the code. As you've found, you're
often better making the table change - that is why Excel doesn't accept
Cross-tabbed data as the source for pivot tables....

Glad to hear you got it working,
Bernie
 
You must log in or register to reply here.

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Stacked Column VBA 1
Crosstab Loosing shape 1
Need help with VBA 3
Copy data in new sheets from criteria using VBA 8
CrossTab query in SQL 2
VBA Code 4
VBA problem importing and auditing Unix reports 2
How to add data Range property at runtime to excel sheet 1

Back
Top