how to fill my empty last row using for loops VBA Excel-CodePudding

Hello i tried to make a data table that consist a range of raw material with list of vendors like this image the data source is in another sheet the idea is to collect every unique content in supplier sheet and extract it to data table sheet (Row 1) so every raw material Category have a column that consist list of suppliers. but the problem i can't make the supplier name fill in every empty last row in each column and i can't have more than one supplier for each column. is there anyone can tell me what have i done wrong in my code?

this is my code

Sub uniquevalues()

Application.EnableEvents = False

Dim arr As New Collection, a
Dim arrS As New Collection, b
Dim rngRawCategory As Variant
Dim rngSupplier As Variant
Dim lrow As Long

rngSupplier = Range("C4:C1000") 'range in supplier sheet (Sheet3)
rngRawCategory = Range("D4:D1000") 'range in supplier sheet (Sheet3)


On Error Resume Next
For Each a In rngRawCategory
    arr.Add a, a
Next

On Error Resume Next
For Each b In rngSupplier
    arrS.Add b, b
Next

Sheet12.Range("B1:Z1000").ClearContents

For i = 1 To arr.Count
    Sheet12.Cells(1, i   1) = arr(i)
    For X = 1 To arrS.Count
        If Sheet3.Cells(X   3, 4).Value = arr(i) Then
            lrow = Sheet12.Cells(Rows.Count, i).End(xlUp).Row   1
            Sheet12.Cells(lrow, i   1) = arrS(X)
        End If
    Next
Next


Application.EnableEvents = True

End Sub

CodePudding user response：

Please, try the next code. It uses a dictionary to extract the unique row materials name and the corresponding supplier for each:

Sub SuppliersPerUniqueMat()
 Dim shMast As Worksheet, shSuppl As Worksheet, lastR As Long, arrMast, arrFin
 Dim dict As Object, arrS, i As Long, j As Long, k As Long, maxCol As Long
 
 Set shMast = Sheet3 ' sheet code Name!
 Set shSuppl = Sheet12
 lastR = shMast.Range("C" & shMast.rows.count).End(xlUp).row   'last row in the master sheet
 arrMast = shMast.Range("C2:D" & lastR).value                  'place the range in an array for faster iteration
 Set dict = CreateObject("Scripting.Dictionary")               'create the necessary dictionary object
 
   For i = 1 To UBound(arrMast)                                ' iterate between the array elements
       dict(arrMast(i, 2)) = dict(arrMast(i, 2)) & "|" & arrMast(i, 1) 'place unique keys (materials) and their suppliers
       If maxCol < UBound(Split(dict(arrMast(i, 2)), "|")) Then
            maxCol = UBound(Split(dict(arrMast(i, 2)), "|"))           'determine the maximum suppliers number
       End If
  Next i
  'redim the filan array to take maximum occurrences rows and dict number of items:
  ReDim arrFin(1 To maxCol   1, 1 To dict.count): k = 1
  
  For i = 0 To dict.count - 1  'iterate between the dictionary keys/items:
        arrFin(k, i   1) = dict.Keys()(i): k = k   1 'place the dictionary key in the first row
        arrS = Split(dict.items()(i), "|")           'split the item to extract suppliers in an array (0 is empty)
        For j = 1 To UBound(arrS)                    'iterate between the array elements
            arrFin(k, i   1) = arrS(j): k = k   1    'place the suppliers of a specific key
        Next j
        k = 1                                        'reinitialize k for the next material
  Next i
  'drop the final array content at once:
  shSuppl.Range("B1").Resize(UBound(arrFin), UBound(arrFin, 2)).value = arrFin
End Sub