Looking for macro that converts a table that I can import into Access

[SanCarlosCyclist]

Hi, I often have a table in excel with many columns and rows that I
want to import into Microsoft Access so that I can query against the
data. The easiest way to explain this is with the following example:

Original Table:

Age
Disease 0-7 8-12 13-15
Diabetes 25 50 100
Asthma 60 20 45

Desired Result:
Disease Age Value
Diabetes 0-7 25
Diabetes 8-12 50
Diabetes 13-15 100
Asthma 0-7 60
Asthma 8-12 20
Asthma 13-15 45


Do any of you have a macro that would accomplish this?

 

[Dave Peterson]

This macro worked ok for me.

I assumed that the headers were in Row 1 and Column A. But you should be able
to adjust the firstrow and firstcol to match your layout.

Option Explicit
Sub testme()

Dim wks As Worksheet
Dim NewWks As Worksheet
Dim iRow As Long
Dim iCol As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim FirstCol As Long
Dim LastCol As Long
Dim oRow As Long

Set wks = Worksheets("Sheet1") '<-- change to what you need
Set NewWks = Worksheets.Add

With wks
FirstRow = 2 'first row after the header
FirstCol = 2 'first column after the header
LastRow = .Cells(.Rows.Count, FirstRow - 1).End(xlUp).Row
LastCol = .Cells(FirstRow - 1, .Columns.Count).End(xlToLeft).Column
End With

With NewWks
.Range("A1").Resize(1, 3).Value _
= Array("Disease", "Age", "Value")
'those ages may be interpreted as dates!
.Range("b1").EntireColumn.NumberFormat = "@" 'text
oRow = 1
For iRow = FirstRow To LastRow
For iCol = FirstCol To LastCol
If IsEmpty(wks.Cells(iRow, iCol).Value) Then
'skip it
Else
oRow = oRow + 1
.Cells(oRow, "A").Value _
= wks.Cells(iRow, FirstCol - 1).Value
.Cells(oRow, "b").Value _
= wks.Cells(FirstRow - 1, iCol).Value
.Cells(oRow, "c").Value = wks.Cells(iRow, "B").Value
End If
Next iCol
Next iRow '.Cells(

.UsedRange.Columns.AutoFit
End With

End Sub


If you're new to macros:

Debra Dalgleish has some notes how to implement macros here:
http://www.contextures.com/xlvba01.html

David McRitchie has an intro to macros:
http://www.mvps.org/dmcritchie/excel/getstarted.htm

Ron de Bruin's intro to macros:
http://www.rondebruin.nl/code.htm

(General, Regular and Standard modules all describe the same thing.)

 

[SanCarlosCyclist]

This macro worked ok for me.

I assumed that the headers were in Row 1 and Column A.  But you should be able
to adjust the firstrow and firstcol to match your layout.

Option Explicit
Sub testme()

     Dim wks As Worksheet
     Dim NewWks As Worksheet
     Dim iRow As Long
     Dim iCol As Long
     Dim FirstRow As Long
     Dim LastRow As Long
     Dim FirstCol As Long
     Dim LastCol As Long
     Dim oRow As Long

     Set wks = Worksheets("Sheet1") '<-- change to what you need
     Set NewWks = Worksheets.Add

     With wks
         FirstRow = 2  'first row after the header
         FirstCol = 2  'first column after the header
         LastRow = .Cells(.Rows.Count, FirstRow - 1).End(xlUp).Row
         LastCol = .Cells(FirstRow - 1, .Columns.Count).End(xlToLeft).Column
     End With

     With NewWks
         .Range("A1").Resize(1, 3).Value _
             = Array("Disease", "Age", "Value")
         'those ages may be interpreted as dates!
         .Range("b1").EntireColumn.NumberFormat = "@" 'text
         oRow = 1
         For iRow = FirstRow To LastRow
             For iCol = FirstCol To LastCol
                 If IsEmpty(wks.Cells(iRow, iCol).Value) Then
                     'skip it
                 Else
                     oRow = oRow + 1
                     .Cells(oRow, "A").Value _
                          = wks.Cells(iRow, FirstCol - 1).Value
                     .Cells(oRow, "b").Value _
                          = wks.Cells(FirstRow - 1, iCol).Value
                     .Cells(oRow, "c").Value = wks.Cells(iRow, "B").Value
                 End If
             Next iCol
         Next iRow '.Cells(

         .UsedRange.Columns.AutoFit
     End With

End Sub

If you're new to macros:

Debra Dalgleish has some notes how to implement macros here:http://www.contextures.com/xlvba01.html

David McRitchie has an intro to macros:http://www.mvps.org/dmcritchie/excel/getstarted.htm

Ron de Bruin's intro to macros:http://www.rondebruin.nl/code.htm

(General, Regular and Standard modules all describe the same thing.)

Hi Dave, this worked perfectly. THANKS!!!
Is there a way to have the macro know if there are more than 3
columns? I sometimes have scenarios where there are many more columns?
If there is not a way to have the macro do all of the columns in a
sheet, what do I need to manually change in the macro if I have more
than 3 columns?

I again thank you for your help. This saves me sooooooooooo much
time.

 

[Dave Peterson]

This line:
LastCol = .Cells(FirstRow - 1, .Columns.Count).End(xlToLeft).Column

Uses all the columns that the header row has. So as long as each column of data
(or at least the last column of data!) has a header, you should be ok.



SanCarlosCyclist wrote:

 

[SanCarlosCyclist]

This line:
LastCol = .Cells(FirstRow - 1, .Columns.Count).End(xlToLeft).Column

Uses all the columns that the header row has.  So as long as each column of data
(or at least the last column of data!) has a header, you should be ok.

SanCarlosCyclist wrote:

<<snipped>>

Hi Dave, that wasn't quite what I wanted to do. below is a better
Example:
Data:

Name

 

[SanCarlosCyclist]

This line:
LastCol = .Cells(FirstRow - 1, .Columns.Count).End(xlToLeft).Column

Uses all the columns that the header row has.  So as long as each column of data
(or at least the last column of data!) has a header, you should be ok.

SanCarlosCyclist wrote:

<<snipped>>

I hit send too quickly. This is what I want to do:
Before:
Name Winter Summer Fall Spring
fred 22 44 11 44
joe 113 454 666 332
Steve 112 4533 543 666


Desired Results:
fred Winter 22
joe Winter 113
Steve Winter 112
fred Summer 44
joe Summer 454
Steve Summer 4533
fred Fall 11
joe Fall 666
Steve Fall 543
fred Spring 44
joe Spring 332
Steve Spring 666


Can you tweek the code that produces the above results? If possible,
it would be great if i could use this macro no matter how many columns
I have in the sheet.
My purpose is that I want to create a table that I can import into
Microsoft Access. Thanks so much.

 

[Dave Peterson]

I don't understand.

I copied your new data into a test worksheet.

I copied the routine that I posted into a new module and ran it.

Except for the column headers, it looked like it gave you what you wanted.

If you don't want the titles, just delete row 1 after the macro runs.

If you want different titles, change this line:

.Range("A1").Resize(1, 3).Value _
= Array("Disease", "Age", "Value")

to what you want.

Again the number of columns that will be "transposed" is based on the headers in
row 1 of the source data.


SanCarlosCyclist wrote:

 

[SanCarlosCyclist]

I don't understand.

I copied your new data into a test worksheet.

I copied the routine that I posted into a new module and ran it.

Except for the column headers, it looked like it gave you what you wanted..

If you don't want the titles, just delete row 1 after the macro runs.

If you want different titles, change this line:

         .Range("A1").Resize(1, 3).Value _
             = Array("Disease", "Age", "Value")

to what you want.

Again the number of columns that will be "transposed" is based on the headers in
row 1 of the source data.

SanCarlosCyclist wrote:

<<snipped>>

Hi David, when I run the macro, I get the following results:
Disease Age Value
fred  Winter $22.00
fred  Summer $22.00
fred  Fall $22.00
fred  Spring $22.00
joe  Winter $113.00
joe  Summer $113.00
joe  Fall $113.00
joe  Spring $113.00
Steve  Winter $112.00
Steve  Summer $112.00
Steve  Fall $112.00
Steve  Spring $112.00


I am trying to get these results:
fred Winter 22
joe Winter 113
Steve Winter 112
fred Summer 44
joe Summer 454
Steve Summer 4533
fred Fall 11
joe Fall 666
Steve Fall 543
fred Spring 44
joe Spring 332
Steve Spring 666

What am I doing wrong?

 

[Roger Govier]

Hi

You're not doing anything wrong.
You just need to tweak Dave's code to step through Columns before Rows,
rather than Rows before columns

oRow = 1
For iCol = FirstCol To LastCol
For iRow = FirstRow To LastRow

If IsEmpty(wks.Cells(iRow, iCol).Value) Then
'skip it
Else
oRow = oRow + 1
.Cells(oRow, "A").Value _
= wks.Cells(iRow, FirstCol - 1).Value
.Cells(oRow, "b").Value _
= wks.Cells(FirstRow - 1, iCol).Value
.Cells(oRow, "c").Value = wks.Cells(iRow, "B").Value
End If
Next iRow
Next iCol '.Cells(

 

[Dave Peterson]

Thanks Roger.

I didn't notice the order that the OP wanted.

 

[SanCarlosCyclist]

Hi

You're not doing anything wrong.
You just need to tweak Dave's code to step through Columns before Rows,
rather than Rows before columns

oRow = 1
         For iCol = FirstCol To LastCol
             For iRow = FirstRow To LastRow

                 If IsEmpty(wks.Cells(iRow, iCol).Value) Then
                     'skip it
                 Else
                     oRow = oRow + 1
                     .Cells(oRow, "A").Value _
                           = wks.Cells(iRow, FirstCol - 1).Value
                     .Cells(oRow, "b").Value _
                           = wks.Cells(FirstRow - 1, iCol).Value
                     .Cells(oRow, "c").Value = wks.Cells(iRow, "B").Value
                 End If
             Next iRow
         Next iCol    '.Cells(

Thanks Roger. I am not sure where to copy the new lines to in the
code. Is it possible for you to copy your changes to Dave's original
code and post the final working code here? As you can guess, I am a
major novice in VB. Again thanks to you and Dave for all of your help.

 

[Dave Peterson]

Option Explicit
Sub testme()

Dim wks As Worksheet
Dim NewWks As Worksheet
Dim iRow As Long
Dim iCol As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim FirstCol As Long
Dim LastCol As Long
Dim oRow As Long

Set wks = Worksheets("Sheet1") '<-- change to what you need
Set NewWks = Worksheets.Add

With wks
FirstRow = 2 'first row after the header
FirstCol = 2 'first column after the header
LastRow = .Cells(.Rows.Count, FirstRow - 1).End(xlUp).Row
LastCol = .Cells(FirstRow - 1, .Columns.Count).End(xlToLeft).Column
End With

With NewWks
.Range("A1").Resize(1, 3).Value _
= Array("Disease", "Age", "Value")
'those ages may be interpreted as dates!
.Range("b1").EntireColumn.NumberFormat = "@" 'text
oRow = 1
For iCol = FirstCol To LastCol
For iRow = FirstRow To LastRow
If IsEmpty(wks.Cells(iRow, iCol).Value) Then
'skip it
Else
oRow = oRow + 1
.Cells(oRow, "A").Value _
= wks.Cells(iRow, FirstCol - 1).Value
.Cells(oRow, "b").Value _
= wks.Cells(FirstRow - 1, iCol).Value
.Cells(oRow, "c").Value = wks.Cells(iRow, "B").Value
End If
Next iRow
Next iCol

.UsedRange.Columns.AutoFit
End With

End Sub

 

[SanCarlosCyclist]

I am sorrrrrryyyyyyyyyyyyyyy for being such a pain in the butt Dave,
but I got the following results:

Disease Age Value
fred     Winter   22      
joe     Winter   113    
Steve   Winter   112    
fred     Summer   22      
joe     Summer   113    
Steve   Summer   112    
fred     Fall     22      
joe     Fall     113    
Steve   Fall     112    
fred     Spring 22      
joe     Spring 113    
Steve   Spring 112    


These are my DESIRED Results:
fred Winter 22
joe Winter 113
Steve Winter 112
fred Summer 44
joe Summer 454
Steve Summer 4533
fred Fall 11
joe Fall 666
Steve Fall 543
fred Spring 44
joe Spring 332
Steve Spring 666

It looks like Winter copied correctly, but not the other ones. It
looks like the macro repeated the Winter values for the other columns.
Any suggestions?

 

[Dave Peterson]

There was a typo in the original code.

Option Explicit
Sub testme()

Dim wks As Worksheet
Dim NewWks As Worksheet
Dim iRow As Long
Dim iCol As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim FirstCol As Long
Dim LastCol As Long
Dim oRow As Long

Set wks = Worksheets("Sheet1") '<-- change to what you need
Set NewWks = Worksheets.Add

With wks
FirstRow = 2 'first row after the header
FirstCol = 2 'first column after the header
LastRow = .Cells(.Rows.Count, FirstRow - 1).End(xlUp).Row
LastCol = .Cells(FirstRow - 1, .Columns.Count).End(xlToLeft).Column
End With

With NewWks
.Range("A1").Resize(1, 3).Value _
= Array("Disease", "Age", "Value")
'those ages may be interpreted as dates!
.Range("b1").EntireColumn.NumberFormat = "@" 'text
oRow = 1
For iCol = FirstCol To LastCol
For iRow = FirstRow To LastRow
If IsEmpty(wks.Cells(iRow, iCol).Value) Then
'skip it
Else
oRow = oRow + 1
.Cells(oRow, "A").Value _
= wks.Cells(iRow, FirstCol - 1).Value
.Cells(oRow, "b").Value _
= wks.Cells(FirstRow - 1, iCol).Value
.Cells(oRow, "c").Value = wks.Cells(iRow, iCol).Value
End If
Next iRow
Next iCol

.UsedRange.Columns.AutoFit
End With

End Sub

 

[SanCarlosCyclist]

IT WORKED!! Woohoooo!
You are the best. Thanks soooooooooooooo much!!

 

[Dave Peterson]

Glad we got it working!

Special thanks to Roger for noticing what I didn't!

 

[Roger Govier]

On the contrary.
I should have tested and seen that
..Cells(oRow, "c").Value = wks.Cells(iRow, "B").Value
should have been changed to
..Cells(oRow, "c").Value = wks.Cells(iRow, iCol).Value

You merely posted the switch in the loops I had made, into the original
code, thereby confusing the OP.
Glad it all worked out in the end

 

[Max]

Here's a simple formulas play which could also do the required
transformation
Assuming your orig table (viz below) is in Sheet1

Age
Disease 0-7 8-12 13-15
Diabetes 25 50 100
Asthma 60 20 45

with
col headers in A2 across
data starts in row3 down

In another sheet, you could place
In A2: =OFFSET(Sheet1!$A$3,INT((ROWS($1:1)-1)/3),)
In B2: =INDEX(Sheet1!$B$2:$D$2,MOD(ROWS($1:1)-1,3)+1)
In C2: =OFFSET(Sheet1!$B$3,INT((ROWS($1:1)-1)/3),MOD(ROWS($1:1)-1,3))
Copy A2:C2 down as far as required to exhaust the desired results