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>

 

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
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
 
Upvote 0
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:
Upvote 0
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?
 
Upvote 0
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.
 
Upvote 0

Forum statistics

Threads
1,213,538
Messages
6,114,218
Members
448,554
Latest member
Gleisner2

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