Macro to Create Table

Slazar

New Member
Joined
Aug 28, 2015
Messages
17
Hi all,

Please help!
I need a macro that does the following:

User will input the information in the table below.

User will then click a button tied to the macro. The macro will return the filled out table in a newly created sheet.
For the table created by the macro, the cells will need to have all borders filled.

Example:

Apple is a Fruit. For Apples, there are two cooking methods (Bake and Fry) with associated pictures 1 and 2 (which are links to another sheet displaying the photo). Part of the outputted table will display all cooking methods, with all associate pictures, for all apples inputted from the user. So it shows the cooking methods for Green Apple and for Red Apple. The outputted table will have empty columns for comments and updates.


Input from User:

ABC
1CategoryTypeColor (ID)
2FruitAppleRed
3FruitAppleGreen
4VegetableBroccoliGreen
5VegetableBroccoliPurple
6MeatChickenWhite

<tbody>
</tbody>




User then Clicks Button

Hidden Table Already Filled Out in Another Sheet:
ABCD
1CategoryTypeCooking MethodPicture
2FruitAppleBake1
3FruitAppleFry2
4VegetableBroccoliBake3
5VegetableBroccoliSteam4
6VegetableBroccoliMicrowave5
7MeatChickenBake6
8MeatChickenGrill7
9MeatChickenFry8

<tbody>
</tbody>




Output from Macro in Newly Created Sheet:
ABCDEFGH
1Item #CategoryTypeColor (ID)Cooking MethodUpdatesCommentsPicture
21FruitAppleRedBake1
32FruitAppleRedFry2
43FruitAppleGreenBake1
54FruitAppleGreenFry2
65VegetableBroccoliGreenBake3
76VegetableBroccoliGreenSteam4
87VegetableBroccoliGreenMicrowave5
98VegetableBroccoliPurpleBake3
109VegetableBroccoliPurpleSteam4
1110VegetableBroccoliPurpleMicrowave5
1211MeatChickenWhiteBake6
1312MeatChickenWhiteGrill7
1413MeatChickenWhiteFry8

<tbody>
</tbody>

 

Some videos you may like

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.

Nine Zero

Well-known Member
Joined
Mar 10, 2016
Messages
622
Here you go tested and works

Sheet1 = user input
Sheet2 = hidden table

Code:
Sub CreateTable()
Dim r, q As Range
Dim lastRow1, lastRow2, lastRow3, currentRow As Integer
Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets.Add(After:= _
             ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    ws.Name = "Table"
Sheets("Sheet1").Select
currentRow = 2
lastRow1 = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
lastRow2 = Sheets("Sheet2").Cells(Sheets("Sheet2").Rows.Count, "A").End(xlUp).Row
For Each r In Range("B2:B" & lastRow1)
    For Each q In Sheets("Sheet2").Range("B2:B" & lastRow2)
        If r.Value = q.Value Then
            Sheets("Table").Range("B" & currentRow).Value = q.Offset(, -1).Value
            Sheets("Table").Range("C" & currentRow).Value = q.Value
            Sheets("Table").Range("D" & currentRow).Value = r.Offset(, 1).Value
            Sheets("Table").Range("E" & currentRow).Value = q.Offset(, 1).Value
            Sheets("Table").Range("H" & currentRow).Value = q.Offset(, 2).Value
            currentRow = currentRow + 1
        End If
    Next q
Next r
Sheets("Table").Range("A1").Value = "Item #"
Sheets("Table").Range("B1").Value = "Category"
Sheets("Table").Range("C1").Value = "Type"
Sheets("Table").Range("D1").Value = "Color (ID)"
Sheets("Table").Range("E1").Value = "Cooking Method"
Sheets("Table").Range("F1").Value = "Updates"
Sheets("Table").Range("G1").Value = "Comments"
Sheets("Table").Range("H1").Value = "Picture"
lastRow3 = Sheets("Table").Cells(Sheets("Sheet2").Rows.Count, "B").End(xlUp).Row
    Sheets("Table").Select
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("A2").Select
    Selection.AutoFill Destination:=Range("A2:A" & lastRow3), Type:=xlFillSeries
    Range("A1:H" & lastRow3).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Sheets("Table").Range("A1:H1").Select
    Selection.Font.Bold = True
End Sub
 

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Try this:-
User Input:- Sheet1
Hidden Table:- Sheet2

Code:
[COLOR=navy]Sub[/COLOR] MG13Aug26
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range, n [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] txt [COLOR=navy]As[/COLOR] [COLOR=navy]String,[/COLOR] ray(), c [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] P [COLOR=navy]As[/COLOR] Variant
[COLOR=navy]With[/COLOR] Sheets("Sheet2")
    [COLOR=navy]Set[/COLOR] Rng = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
[COLOR=navy]End[/COLOR] With
[COLOR=navy]

With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR=navy]
For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
    txt = Dn.Value & Dn.Offset(, 1).Value
    [COLOR=navy]If[/COLOR] Not .exists(txt) [COLOR=navy]Then[/COLOR] .Add txt, Array(New Collection, New Collection)
     .Item(txt)(0).Add Dn.Offset(, 2)
    .Item(txt)(1).Add Dn.Offset(, 3)
[COLOR=navy]Next[/COLOR]
[COLOR=navy]
With[/COLOR] Sheets("Sheet1")
    [COLOR=navy]Set[/COLOR] Rng = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
[COLOR=navy]End[/COLOR] With

ReDim Preserve ray(1 To 8, 1 To 1)
ray(1, 1) = "Item #": ray(2, 1) = "Category": ray(3, 1) = "Type": ray(4, 1) = "Color (ID)"
ray(5, 1) = "Cooking Method": ray(6, 1) = "Updates": ray(7, 1) = "Comments": ray(8, 1) = "Picture"
c = 1
[COLOR=navy]

For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
    txt = Dn.Value & Dn.Offset(, 1).Value
        [COLOR=navy]If[/COLOR] .exists(txt) [COLOR=navy]Then[/COLOR]
          [COLOR=navy]For[/COLOR] n = 1 To .Item(txt)(0).Count
             c = c + 1
             ReDim Preserve ray(1 To 8, 1 To c)
              ray(1, c) = c - 1
              ray(2, c) = Dn.Value
              ray(3, c) = Dn.Offset(, 1).Value
              ray(4, c) = Dn.Offset(, 2).Value
              ray(5, c) = .Item(txt)(0)(n)
              ray(8, c) = .Item(txt)(1)(n)
          [COLOR=navy]Next[/COLOR] n
    [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] Dn
[COLOR=navy]End[/COLOR] With
[COLOR=navy]

Dim[/COLOR] sht [COLOR=navy]As[/COLOR] Worksheet
Sheets.Add after:=Sheets(Sheets.Count)
[COLOR=navy]Set[/COLOR] sht = ActiveSheet
 [COLOR=navy]With[/COLOR] sht.Range("A1").Resize(c, 8)
      .Value = Application.Transpose(ray)
      .Borders.Weight = 2
      .HorizontalAlignment = xlCenter
      .Columns.AutoFit
  [COLOR=navy]End[/COLOR] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
 
Last edited:

Slazar

New Member
Joined
Aug 28, 2015
Messages
17
Great! They both work!

Only issue is the link to the picture is gone after running the macro. In the newly created table, it just shows the number in text but is not a clickable link like it is in the hidden table. How do I fix this?
 

Slazar

New Member
Joined
Aug 28, 2015
Messages
17
Any ideas on how to preserve hyperlink after running the macro? The link is to another place in the Excel spreadsheet that shows a picture and the text displayed for the link are just numbers.
 

Watch MrExcel Video

Forum statistics

Threads
1,108,655
Messages
5,524,124
Members
409,561
Latest member
ay123

This Week's Hot Topics

Top