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; 1 week ago.

                Comment


                • #9


                  anyone trying it?

                  Comment

                  Working...
                  X