Announcement

Collapse
No announcement yet.

VBA code to return multiple entries in each row based on criteria

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • VBA code to return multiple entries in each row based on criteria



    Hi,

    I am looking for a VBA help to convert Existing data into required format as per attached sheet. I have a long rows of data so I need VBA to automate the process. Someone could help me?
    Attached Files

  • #2
    Unfortunately i can't test because my mac doesn't support the dictionary object, but try:
    Code:
    Sub formatData()
        Dim d As Object, bomList As Object
        Dim a(), b(), k, kk, v, vv, vvv 'Variant
        Dim i As Long, j As Long
        Dim bom As Worksheet, data As Worksheet
        
        Set data = ThisWorkbook.Sheets("Required format") '<--Change to sheet name of unformatted data
        a = data.Range("A3").CurrentRegion.Value '<-Possibly change A3 to A1
        
        Set bom = ThisWorkbook.Sheets("BOM List")
        b = bom.Range("A1").CurrentRegion.Value
        Set d = CreateObject("Scripting.Dictionary")
        Set bomList = CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(b)
            If Not bomList.exists(b(i, 1)) Then bomList.add b(i, 1), CreateObject("Scripting.Dictionary")
            bomList(b(i, 1))(b(i, 2)) = b(i, 2)
        Next i
        For i = 2 To UBound(a)
            If Not d.exists(a(i, 1)) Then d.add a(i, 1), CreateObject("Scripting.Dictionary")
            If Not d(a(i, 1)).exists(a(i, 2)) Then d(a(i, 1)).add a(i, 2), CreateObject("Scripting.Dictionary")
            If bomList.exists(a(i, 2)) Then
                Set d(a(i, 1))(a(i, 2)) = bomList(a(i, 2))
            Else
                d(a(i, 1))(a(i, 2)).add "-", "-"
            End If
            j = j + d(a(i, 1))(a(i, 2)).Count
        Next i
        ReDim b(1 To j + 1, 1 To 3)
        b(1, 1) = "Parent Code"
        b(1, 2) = "Item Code"
        b(1, 3) = "Bill of material code"
        j = 1
        For Each k In d.keys
            Set v = d(k)
            b(j + 1, 1) = k
            For Each kk In v.keys
                Set vv = v(kk)
                b(j + 1, 2) = kk
                For Each vvv In vv
                    j = j + 1
                    b(j, 3) = vvv
                Next vvv
            Next kk
        Next k
        With ThisWorkbook.Sheets.add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Range("A1").Resize(UBound(b), UBound(b, 2))
            .Value = b
            .Resize(1).Font.Bold = True
            .Borders.LineStyle = 1
            .EntireColumn.AutoFit
        End With
    End Sub

    Comment


    • #3
      Thanks Trunten,

      Bulls eye. task Accomplished.

      Thanks

      Comment


      • #4
        check your spelling

        Comment


        • #5
          Also, this will make the keys none case sensitive. Still, check your spelling of the keys.

          Code:
          Sub formatData()
              Dim d As Object, bomList As Object
              Dim a(), b(), k, kk, v, vv, vvv 'Variant
              Dim i As Long, j As Long
              Dim bom As Worksheet, data As Worksheet
              
              Set data = ThisWorkbook.Sheets("Required format") '<--Change to sheet name of unformatted data
              a = data.Range("A3").CurrentRegion.Value '<-Possibly change A3 to A1
              
              Set bom = ThisWorkbook.Sheets("BOM List")
              b = bom.Range("A1").CurrentRegion.Value
              Set d = CreateObject("Scripting.Dictionary")
              Set bomList = CreateObject("Scripting.Dictionary")
              d.CompareMode = vbTextCompare
              bomList.CompareMode = vbTextCompare
              For i = 2 To UBound(b)
                  If Not bomList.exists(b(i, 1)) Then
                      bomList.add b(i, 1), CreateObject("Scripting.Dictionary")
                      bomList(b(i, 1)).CompareMode = vbTextCompare
                  End If
                  bomList(b(i, 1))(b(i, 2)) = b(i, 2)
              Next i
              For i = 2 To UBound(a)
                  If Not d.exists(a(i, 1)) Then
                      d.add a(i, 1), CreateObject("Scripting.Dictionary")
                      d(a(i, 1)).CompareMode = vbTextCompare
                  End If
                  If Not d(a(i, 1)).exists(a(i, 2)) Then
                      d(a(i, 1)).add a(i, 2), CreateObject("Scripting.Dictionary")
                      d(a(i, 1))(a(i, 2)).CompareMode = vbTextCompare
                  End If
                  If bomList.exists(a(i, 2)) Then
                      d(a(i, 1)).remove (a(i, 2))
                      d(a(i, 1)).add a(i, 2), bomList(a(i, 2))
                      j = j + d(a(i, 1))(a(i, 2)).Count
                  Else
                      If Not d(a(i, 1))(a(i, 2)).exists("-") Then
                          d(a(i, 1))(a(i, 2)).add "-", "-"
                          j = j + 1
                      End If
                  End If
              Next i
              ReDim b(1 To j + 1, 1 To 3)
              b(1, 1) = "Parent Code"
              b(1, 2) = "Item Code"
              b(1, 3) = "Bill of material code"
              j = 1
              For Each k In d.keys
                  Set v = d(k)
                  b(j + 1, 1) = k
                  For Each kk In v.keys
                      Set vv = v(kk)
                      b(j + 1, 2) = kk
                      For Each vvv In vv.items
                          j = j + 1
                          b(j, 3) = vvv
                      Next vvv
                  Next kk
              Next k
              With ThisWorkbook.Sheets.add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Range("A1").Resize(UBound(b), UBound(b, 2))
                  .Value = b
                  .Resize(1).Font.Bold = True
                  .Borders.LineStyle = 1
                  .EntireColumn.AutoFit
              End With
          End Sub

          Comment


          • #6
            Thanks. S i tweaked spelling and works great. U have reduced my work to a minute. thanks once again

            Comment


            • #7
              No problem. Glad I could help

              Comment


              • #8
                Hi trentun,

                Buddy, when I apply your code to multilevel Bill of material, It does not go well and I am back to tons of work. I have slightly modified my file, can u help me resolve it ? Your help is highly appreciable.
                Attached Files
                Last edited by gentle_20052006; August 8th, 2019, 00:39.

                Comment


                • #9
                  anyone trying it?

                  Comment


                  • #10
                    Code:
                    Option Explicit
                    
                    Sub formatData()
                        Dim rawData() As Variant
                        Dim sht As Worksheet
                        Dim r As Range
                        Dim i As Long
                        Dim rowNum As Long
                        Dim itemCode As String
                        
                        Set sht = ThisWorkbook.Sheets("Master BOM and Required Format") '<- Sheet containing raw data
                        
                        Set r = sht.Range("A3").CurrentRegion '<- Range of raw data on worksheet 'sht'
                        
                        If r.Columns.count <> 3 Then Exit Sub '<- Exit if raw data range is not in the expected format.
                        
                        rawData = r.Value
                        Set sht = ThisWorkbook.Sheets.add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count))
                        rowNum = 0
                        For i = 1 To UBound(rawData)
                            itemCode = rawData(i, 2)
                            If InStr(1, itemCode, "Cycle", vbTextCompare) Then
                                rowNum = rowNum + 1
                                sht.Cells(rowNum, 1).Value = itemCode
                                rowNum = rowNum + outputChildren(rawData(i, 3), rawData, sht, rowNum, 2)
                            End If
                        Next i
                    End Sub
                    
                    Function outputChildren(ByVal itemCode As String, ByRef rawData As Variant, ByRef sht As Worksheet, ByVal rowNum As Long, ByVal colNum As Long)
                        Dim i As Long
                        Dim count As Long
                        
                        count = -1
                        sht.Cells(rowNum, colNum).Value = itemCode
                        For i = 1 To UBound(rawData)
                            If StrComp(itemCode, rawData(i, 2), vbTextCompare) = 0 Then
                                count = count + 1
                                sht.Cells(rowNum + count, colNum).Value = itemCode
                                count = count + outputChildren(rawData(i, 3), rawData, sht, rowNum + count, colNum + 1)
                            End If
                        Next i
                        outputChildren = Application.Max(0, count)
                    End Function

                    Comment


                    • #11


                      Thanks Trunten

                      Comment

                      Working...
                      X