How to generate a table in VBA?

cmondeau

cmondeau

Board Regular
Joined
Sep 23, 2014
Messages
86
Greetings all!

I am having a hard time finding some code for a table generator in VBA. What I'd like to do is create a table using the unique colors and animals as row & column headers. Eventually I would like to have the table filled with the number for each combination (tried countifs, but was curious about using vlookup). I'm lost, because this seems so simple, yet I think I keep convoluting it...

Code: 
[TABLE="width: 621"]
<tbody>[TR]
[TD]Colors[/TD]
[TD]Animals[/TD]
[TD][/TD]
[TD][/TD]
[TD]Red[/TD]
[TD]Orange[/TD]
[TD]Yellow[/TD]
[TD]Green[/TD]
[TD]Blue[/TD]
[/TR]
[TR]
[TD]Orange[/TD]
[TD]Dog[/TD]
[TD][/TD]
[TD]Bird[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]0[/TD]
[/TR]
[TR]
[TD]Green[/TD]
[TD]Dog[/TD]
[TD][/TD]
[TD]Cat[/TD]
[TD]2[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]0[/TD]
[/TR]
[TR]
[TD]Red[/TD]
[TD]Cat[/TD]
[TD][/TD]
[TD]Dog[/TD]
[TD]2[/TD]
[TD]1[/TD]
[TD]2[/TD]
[TD]1[/TD]
[TD]0[/TD]
[/TR]
[TR]
[TD]Blue[/TD]
[TD]Fish[/TD]
[TD][/TD]
[TD]Frog[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]0[/TD]
[/TR]
[TR]
[TD]Blue[/TD]
[TD]Fish[/TD]
[TD][/TD]
[TD]Fish[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]Red[/TD]
[TD]Dog[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Red[/TD]
[TD]Cat[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Yellow[/TD]
[TD]Dog[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Yellow[/TD]
[TD]Dog[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Red[/TD]
[TD]Dog[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
 
Sort by date Sort by votes
Try

Code: 
Sub gen_Table()
Const OutputCell As String = "F1"


With Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
    .Offset(, 1).AdvancedFilter xlFilterCopy, , Range(OutputCell), True
    .AdvancedFilter xlFilterCopy, , Range(OutputCell).Offset(, 1), True
End With


With Range(OutputCell)
    .Clear
    Range(.Offset(1, 1), Cells(.Offset(Rows.Count - .Row, 1).End(xlUp).Row, .Offset(, 1).Column)).Copy
    .Offset(, 1).PasteSpecial , , , True
    Range(.Offset(1, 1), Cells(.Offset(Rows.Count - .Row, 1).End(xlUp).Row, .Offset(, 1).Column)).Clear
End With


With Range(OutputCell).CurrentRegion
    With .Resize(.Rows.Count - 1, .Columns.Count - 1).Offset(1, 1)
        .FormulaR1C1 = Replace("=COUNTIFS(R2C1:R@C1,R1C,R2C2:R@C2,RC6)", "@", Range("A" & Rows.Count).End(xlUp).Row)
        .Value = .Value
    End With
End With
End Sub







Excel 2013
ABCDEFGHIJK
1ColorsAnimalsOrangeGreenRedBlueYellow
2OrangeDogDog11202
3GreenDogCat00200
4RedCatFish00020
5BlueFish
6BlueFish
7RedDog
8RedCat
9YellowDog
10YellowDog
11RedDog
Sheet10
 
Upvote 0
You are a beautiful and wonderful individual! Is there a way that I can insert a clear command so that I can run the code without having to manually clear the matrix from F1?
 
Upvote 0
thanks

yes just add

Code: 
range([COLOR=#333333]OutputCell [/COLOR]).CurrentRegion.Clear

after


Code: 
Const OutputCell As String = "F1"

you can also choose to return your table elsewhere by changing the above line, Const OutputCell As String = "Z1" will output starting in Z1 for instance
 
Upvote 0
cmondeau,

The following is based on your text display.

Sample raw data:


Excel 2007
ABCDEFGHI
1ColorsAnimals
2OrangeDog
3GreenDog
4RedCat
5BlueFish
6BlueFish
7RedDog
8RedCat
9YellowDog
10YellowDog
11RedDog
12
Sheet1


After the macro:


Excel 2007
ABCDEFGHI
1ColorsAnimalsRedOrangeYellowGreenBlue
2OrangeDogBird00000
3GreenDogCat20000
4RedCatDog21210
5BlueFishFrog00000
6BlueFishFish00002
7RedDog
8RedCat
9YellowDog
10YellowDog
11RedDog
12
Sheet1
Cell Formulas
RangeFormula
E2=SUMPRODUCT(--($B$2:$B$11=$D2),--($A$2:$A$11=E$1))
F2=SUMPRODUCT(--($B$2:$B$11=$D2),--($A$2:$A$11=F$1))
G2=SUMPRODUCT(--($B$2:$B$11=$D2),--($A$2:$A$11=G$1))
H2=SUMPRODUCT(--($B$2:$B$11=$D2),--($A$2:$A$11=H$1))
I2=SUMPRODUCT(--($B$2:$B$11=$D2),--($A$2:$A$11=I$1))


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Code: 
Sub CreateTable()
' hiker95, 10/14/2014, ME811653
Dim lr1 As Long, lr2 As Long
Application.ScreenUpdating = False
Columns("D:I").ClearContents
Range("D2").Resize(5).Value = Application.Transpose(Array("Bird", "Cat", "Dog", "Frog", "Fish"))
Range("E1").Resize(, 5).Value = Array("Red", "Orange", "Yellow", "Green", "Blue")
lr1 = Cells(Rows.Count, 1).End(xlUp).Row
lr2 = Cells(Rows.Count, 4).End(xlUp).Row
With Range("E2:I" & lr2)
  .Formula = "=SUMPRODUCT(--($B$2:$B$" & lr1 & "=$D2),--($A$2:$A$" & lr1 & "=E$1))"
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the CreateTable macro.
 
Upvote 0
Thank you all! @VBA Geek: could you comment out what each line of your code does? I want to make sure I understand what's going on should I reference each later. I would like to fiddle around with it and see if I can switch the Animals and Colors on the matrix so I can add more colors as needed, all while keeping the first to columns (A and B) in the same orientation.

Like this:

Code: 
[TABLE="width: 384"]
 <colgroup><col width="64" span="6" style="width:48pt"> </colgroup><tbody>[TR]
  [TD="width: 64"][/TD]
  [TD="width: 64"]Cat[/TD]
  [TD="width: 64"]Dog[/TD]
  [TD="width: 64"]Fish[/TD]
  [TD="width: 64"]Frog[/TD]
  [TD="width: 64"]Bird[/TD]
 [/TR]
 [TR]
  [TD]Blue[/TD]
  [TD="align: right"]0[/TD]
  [TD="align: right"]0[/TD]
  [TD="align: right"]0[/TD]
  [TD="align: right"]0[/TD]
  [TD="align: right"]0[/TD]
 [/TR]
 [TR]
  [TD]Green[/TD]
  [TD="align: right"]0[/TD]
  [TD="align: right"]2[/TD]
  [TD="align: right"]0[/TD]
  [TD="align: right"]0[/TD]
  [TD="align: right"]1[/TD]
 [/TR]
 [TR]
  [TD]Orange[/TD]
  [TD="align: right"]0[/TD]
  [TD="align: right"]0[/TD]
  [TD="align: right"]0[/TD]
  [TD="align: right"]1[/TD]
  [TD="align: right"]1[/TD]
 [/TR]
 [TR]
  [TD]Yellow[/TD]
  [TD="align: right"]1[/TD]
  [TD="align: right"]1[/TD]
  [TD="align: right"]0[/TD]
  [TD="align: right"]0[/TD]
  [TD="align: right"]1[/TD]
 [/TR]
 [TR]
  [TD]Red[/TD]
  [TD="align: right"]1[/TD]
  [TD="align: right"]0[/TD]
  [TD="align: right"]1[/TD]
  [TD="align: right"]0[/TD]
  [TD="align: right"]2[/TD]
 [/TR]
 [TR]
  [TD]Indigo[/TD]
  [TD][/TD]
  [TD][/TD]
  [TD][/TD]
  [TD][/TD]
  [TD][/TD]
 [/TR]
 [TR]
  [TD]Violet[/TD]
  [TD][/TD]
  [TD][/TD]
  [TD][/TD]
  [TD][/TD]
  [TD][/TD]
 [/TR]
 [TR]
  [TD]Magenta[/TD]
  [TD][/TD]
  [TD][/TD]
  [TD][/TD]
  [TD][/TD]
  [TD][/TD]
 [/TR]
 [TR]
  [TD]Cyan[/TD]
  [TD][/TD]
  [TD][/TD]
  [TD][/TD]
  [TD][/TD]
  [TD][/TD]
 [/TR]
 [TR]
  [TD]…[/TD]
  [TD][/TD]
  [TD][/TD]
  [TD][/TD]
  [TD][/TD]
  [TD][/TD]
[/TR]
</tbody>[/TABLE]
 
Upvote 0
here's an updated version as my previous code gave wrong results if your changed the Outputcell address string



Code: 
Sub gen_TableV2()
Const OutputCell As String = "E1" ' set output cell


With Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
    .Offset(, 1).AdvancedFilter xlFilterCopy, , Range(OutputCell), True ' copies uniques animals in outputcell
    .AdvancedFilter xlFilterCopy, , Range(OutputCell).Offset(, 1), True ' copies unique colors on the right of outputcell
End With




With Range(OutputCell)
    .Clear ' clear outputcell header
    Range(.Offset(1, 1), Cells(.Offset(Rows.Count - .Row, 1).End(xlUp).Row, .Offset(, 1).Column)).Copy ' copy paste transpose the colors next to output cell
    .Offset(, 1).PasteSpecial , , , True
    Range(.Offset(1, 1), Cells(.Offset(Rows.Count - .Row, 1).End(xlUp).Row, .Offset(, 1).Column)).Clear
End With




With Range(OutputCell).CurrentRegion ' apply formulas to count given the 2 conditions
    With .Resize(.Rows.Count - 1, .Columns.Count - 1).Offset(1, 1)
        .Formula = Replace("=COUNTIFS($A$2:$A$@," & _
                    Range(OutputCell).Offset(, 1).Address(True, False) & ", $B$2:$B$@," & _
                    Range(OutputCell).Offset(1).Address(False, True) & ")", "@", Range("A" & Rows.Count).End(xlUp).Row)
        .Value = .Value
    End With
End With
End Sub
 
Upvote 0
cmondeau,

Thanks for the feedback.

You are very welcome. Glad we could help.


1. Did you even try my macro?

2. Are you looking for a macro that will adjust for the varying number of animals, and, colors?
 
Upvote 0
Forgive me, please!

I did run your code, and it worked very well. I had contemplated about using arrays, but got hung up on how exactly to create a dynamic array. The problem that I asked for above was how I tried simplifying my real life problem. As you may have seen most of my recent posts have been about creating a stock-cutting optimizer, so there are a lot of my threads out there with bits and pieces of an ever-changing design.

So to answer your second question, yes, I am looking to create a macro that will adjust for a varying number of animals and colors, BUT, I am actually translating that code over to the pipe template :eeek:.

Again I do apologize for not recognizing the Forum, and all the alternate resources you provide. I really can say that I appreciate everyone's inputs, and have learned a tremendous amount.

Thanks for your time and consideration.
 
Upvote 0
cmondeau,

Thanks for the feedback.

yes, I am looking to create a macro that will adjust for a varying number of animals and colors
Click to expand...

I could adjust my macro to accommodate for a varying number of animals, and, colors?


BUT, I am actually translating that code over to the pipe template
Click to expand...

1. Do you have another thread for the pipe template?

2. If so, can we have a link to it.


If not, then when you create a new thread for the pipe template, you can send me a Private Message with a link to the new thread, and, I will have a look.
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Solved
XLOOKUP return multiple column and ignore blanks
Replies
5
Views
3K
Peter_SSs
Peter_SSs
ChristineJ
  • Solved
Adapt formula for one of many choices
Replies
3
Views
119
Tetra201
Tetra201
B
  • Solved
Need code that converts colors from the RGB code to the Natural Color System (NCS)
Replies
6
Views
557
PeteWright
PeteWright
S
  • Solved
Formula or VBA code to format certain cells based on the value.
2 3
Replies
22
Views
417
Joe4
Joe4
K
  • Solved
vba run time error 424
Replies
3
Views
122
Peter_SSs
Peter_SSs

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top