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

rjheibel

New Member
Joined
Mar 8, 2018
Messages
42
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
ABCDEFGHIJKL
1
2Sum -> $72.00$0.00$76.00$354.00$0.00$93.00$17.00
3
4Item IDItem Description Item CodeDuration% of Total costResource Code 1Resource Code 2Resource Code 3Resource Code 4Resource Code 5Resource Code 6Resource Code 7
5108Item 10820.000.000.0080.000.0050.0010.00
6109Item 1090.000.002.005.000.004.005.00
7101Item 10110.000.002.0060.000.0012.002.00
8102Item 1020.000.003.0040.000.009.000.00
9103Item 1032.000.004.0050.000.006.000.00
10104Item 10411.000.000.0080.000.005.000.00
11107Item 10715.000.000.002.000.003.000.00
12105Item 1050.000.009.0030.000.002.000.00
13110Item 1108.000.000.004.000.002.000.00
14111Item 1116.000.006.003.000.000.000.00
15106Item 1060.000.0050.000.000.000.000.00
Sheet1
Cell Formulas
RangeFormula
F2:L2F2=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
ABC
1Item IDResource Code Value
2108Resource Code 120
3107Resource Code 115
4104Resource Code 111
5101Resource Code 110
6110Resource Code 18
7111Resource Code 16
8103Resource Code 12
9106Resource Code 350
10105Resource Code 39
11111Resource Code 36
12103Resource Code 34
13102Resource Code 33
14101Resource Code 32
15109Resource Code 32
16108Resource Code 480
17104Resource Code 480
18101Resource Code 460
19103Resource Code 450
20102Resource Code 440
21105Resource Code 430
22109Resource Code 45
23110Resource Code 44
24111Resource Code 43
25107Resource Code 42
26108Resource Code 650
27101Resource Code 612
28102Resource Code 69
29103Resource Code 66
30104Resource Code 65
31109Resource Code 64
32107Resource Code 63
33105Resource Code 62
34110Resource Code 62
35108Resource Code 710
36109Resource Code 75
37101Resource Code 72
Sheet2
 

Excel Facts

Format cells as date
Select range and press Ctrl+Shift+3 to format cells as date. (Shift 3 is the # sign which sort of looks like a small calendar).
Your data on Sheet1, the results on Sheet2

Try this:

VBA Code:
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
 
Upvote 0
Solution
I'm glad to help you. Thanks for the feedback.
 
Upvote 0
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.
 
Upvote 0
Check:

VBA Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,567
Messages
6,114,342
Members
448,570
Latest member
rik81h

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