VBA code to create a 3 column import template from table with 100 columns

[rjheibel]

I have a spreadsheet table that details Items ID's in rows that have multiple resource quantities assigned to them in the columns. There maybe up to 200 columns with this data. I want to create a macro that will create a new sheet that transfers this data into three columns (Item ID, Resource Code, and quantity). I need to do this in order to import this data into another program. Im currently doing this manually which takes a lot of time and cannot figure out the code to do this. Please help, THANKS!

I only want resources with values greater than zero to be in list, although i could always filter this out after.

Below is an simplified version of the spreadsheet with the data:

example file.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L
1
2					Sum ->	$72.00	$0.00	$76.00	$354.00	$0.00	$93.00	$17.00
3
4	Item ID	Item Description	Item Code	Duration	% of Total cost	Resource Code 1	Resource Code 2	Resource Code 3	Resource Code 4	Resource Code 5	Resource Code 6	Resource Code 7
5	108	Item 108				20.00	0.00	0.00	80.00	0.00	50.00	10.00
6	109	Item 109				0.00	0.00	2.00	5.00	0.00	4.00	5.00
7	101	Item 101				10.00	0.00	2.00	60.00	0.00	12.00	2.00
8	102	Item 102				0.00	0.00	3.00	40.00	0.00	9.00	0.00
9	103	Item 103				2.00	0.00	4.00	50.00	0.00	6.00	0.00
10	104	Item 104				11.00	0.00	0.00	80.00	0.00	5.00	0.00
11	107	Item 107				15.00	0.00	0.00	2.00	0.00	3.00	0.00
12	105	Item 105				0.00	0.00	9.00	30.00	0.00	2.00	0.00
13	110	Item 110				8.00	0.00	0.00	4.00	0.00	2.00	0.00
14	111	Item 111				6.00	0.00	6.00	3.00	0.00	0.00	0.00
15	106	Item 106				0.00	0.00	50.00	0.00	0.00	0.00	0.00
Sheet1

Cell Formulas
Range	Formula
F2:L2	F2	=SUM(F5:F15)

Next is the example of the end result that I want the information in: (note this copies the item ID in column A where the value in column F - L is greater than zero. the value in row 4 for the resource name is then copies in column B of the new taable for each row.

Book1
	A	B	C
1	Item ID	Resource Code	Value
2	108	Resource Code 1	20
3	107	Resource Code 1	15
4	104	Resource Code 1	11
5	101	Resource Code 1	10
6	110	Resource Code 1	8
7	111	Resource Code 1	6
8	103	Resource Code 1	2
9	106	Resource Code 3	50
10	105	Resource Code 3	9
11	111	Resource Code 3	6
12	103	Resource Code 3	4
13	102	Resource Code 3	3
14	101	Resource Code 3	2
15	109	Resource Code 3	2
16	108	Resource Code 4	80
17	104	Resource Code 4	80
18	101	Resource Code 4	60
19	103	Resource Code 4	50
20	102	Resource Code 4	40
21	105	Resource Code 4	30
22	109	Resource Code 4	5
23	110	Resource Code 4	4
24	111	Resource Code 4	3
25	107	Resource Code 4	2
26	108	Resource Code 6	50
27	101	Resource Code 6	12
28	102	Resource Code 6	9
29	103	Resource Code 6	6
30	104	Resource Code 6	5
31	109	Resource Code 6	4
32	107	Resource Code 6	3
33	105	Resource Code 6	2
34	110	Resource Code 6	2
35	108	Resource Code 7	10
36	109	Resource Code 7	5
37	101	Resource Code 7	2
Sheet2

 

[DanteAmor]

Your data on Sheet1, the results on Sheet2

Try this:

Sub transfers_data()
  Dim sh1 As Worksheet
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, lr As Long, lc As Long, n As Long
  
  Set sh1 = Sheets("Sheet1")
  lr = sh1.Range("A" & Rows.Count).End(3).Row
  lc = sh1.Cells(4, Columns.Count).End(1).Column
  a = sh1.Range("A4", sh1.Cells(lr, lc))
  n = WorksheetFunction.CountIf(sh1.Range("F5", sh1.Cells(lr, lc)), ">0")
  ReDim b(1 To n, 1 To 3)
  
  For i = 2 To UBound(a, 1)
    For j = 6 To UBound(a, 2)
      If a(i, j) > 0 Then
        k = k + 1
        b(k, 1) = a(i, 1)
        b(k, 2) = a(1, j)
        b(k, 3) = a(i, j)
      End If
    Next
  Next
  
  With Sheets("Sheet2")
    .Range("A2").Resize(n, 3).Value = b
    .Range("A1:C" & n + 1).Sort .Range("B1"), xlAscending, .Range("C1"), , xlDescending, , , xlYes
  End With
End Sub

 

[rjheibel]

Dante, This seems to work beautifully! Thanks for the help.

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.

 

[rjheibel]

Dante, Would you be willing to provide a explanation of the code you used to provide the solution? I am trying to understand the code so I can modify it to work in a similar spreadsheet, but not exact format. I would love to be able to understand it enough so I can try to modify it myself.

 

[DanteAmor]

Check:

Sub transfers_data()
  Dim sh1 As Worksheet
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, lr As Long, lc As Long, n As Long
  
  'Sheet with source data
  Set sh1 = Sheets("Sheet1")
  ' last row with data from column A
  lr = sh1.Range("A" & Rows.Count).End(3).Row
  'last column with data taking row 4 as reference
  lc = sh1.Cells(4, Columns.Count).End(1).Column
  'Puts all the data in the matrix 'a', starting in cell A4 and up to the last row and last column with data.
  a = sh1.Range("A4", sh1.Cells(lr, lc))
  'Counts the number of values ??greater than 0
  n = WorksheetFunction.CountIf(sh1.Range("F5", sh1.Cells(lr, lc)), ">0")
  'Size the output matrix 'b' with the number of rows n and 3 columns
  ReDim b(1 To n, 1 To 3)
  
  'Loop for each row in array 'a', starting at row 2
  For i = 2 To UBound(a, 1)
    'Loop for each column in array 'a', starting at column 6 (F)
    For j = 6 To UBound(a, 2)
      'checks if the value of the intersection i , j is greater than 0
      If a(i, j) > 0 Then
        'If greater than 0, increment one row in counter k
        k = k + 1
        'Stores in array 'b' in row k, column 1, the value of column A
        b(k, 1) = a(i, 1)
        'Stores in array 'b' in row k, column 2, the value of the column header
        b(k, 2) = a(1, j)
        'Stores in array 'b' in row k, column 3, the value of the cell
        b(k, 3) = a(i, j)
      End If
    Next
  Next
  
  With Sheets("Sheet2")
    'Pass the content of array 'b' to sheet2
    .Range("A2").Resize(n, 3).Value = b
    'Sort the data by column B and column C
    .Range("A1:C" & n + 1).Sort .Range("B1"), xlAscending, .Range("C1"), , xlDescending, , , xlYes
  End With
End Sub

 

[rjheibel]

Thanks for the descriptions on the statements! @DanteAmor