[Solved] Excel VBA - Rearranging the data into a report format

[SpicyVNoodle]

Hello, I'm new to the world of VBA and I need some help for coding.

I need the following set of data to be put into a report format as below;

Data Set

Report Format

What the report should look like;

1. Count the number of Orders and put the number in column A. For example there are total 3 orders: OR-01, AA_01, and BB~02. Then column A shows 1, 2 or 3)
2. Per each of Order, put the Item name, Product number, Color, Type, Unit (always cm) then put the Size based on the number of Quantity. For example the first item has 4 Quantity for 50 Size, then put 50 50 50 50. Once it goes over 5, put the data in the next section.
3. If the quantity is more than 10, put Size x Quality in a merged cell. For example if the size is 23 and quality is 15, put it as 23 x 15 for column G and H then the next item is put in the column I
4. Count of each of the Item and Color
5. Total of the each of Item and Color

Any part of coding for each of the section would be much appreciated. Or any ideas to how to approach to code this format would be also very appreciated.

 

[SpicyVNoodle]

I was thinking that it may be easy to use loop to grab data in each roll instead of checking the different number of Quantity.

I found this code on the web that can copy additional rows for the number of Quantity.

Sub CopyData()
Dim xRow As Long
Dim VInSertNum As Variant
xRow = 1

Do While (Cells(xRow, "A") <> "")
VInSertNum = Cells(xRow, "N")
If ((VInSertNum > 1) And IsNumeric(VInSertNum)) Then
Range(Cells(xRow, "A"), Cells(xRow, "N")).Copy
Range(Cells(xRow + 1, "A"), Cells(xRow + VInSertNum - 1, "N")).Select
Selection.Insert Shift:=xlDown
xRow = xRow + VInSertNum - 1
End If
xRow = xRow + 1
Loop
End Sub

I still don't know how to populate the Size data for only 5 times from Column G to Column K then continue inputting the Size data in the next row without inputting Name, Product No, Color, Type, Unit data.

 

[Seemanto Saha]

Dear SpicyVNoodle,

Thanks for reaching us. I understand that you want to rearrange your data into a report format. To rearrange the data in your specified format, first, you have to create a Sheet named “Report” in your Excel Workbook and then manually write the required headers in Row 1, starting from Column A. Then insert the following code in your VBA Editor Module and press function key F5 key to execute it.

Private Function UniqueValues(arr)
    Dim ret() As String
    ReDim ret(1 To 1)
    ret(1) = arr(1)

    For i = 2 To UBound(arr)
        test = False
        For j = 1 To UBound(ret)
            If arr(i) = ret(j) Then
                test = True
                Exit For
            End If
        Next j
        If test = False Then
            ReDim Preserve ret(1 To UBound(ret) + 1)
            ret(UBound(ret)) = arr(i)
        End If
    Next i

    UniqueValues = ret
    
End Function
Sub rearrangeDataInReportFormat()
    
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim lastRow As Integer
    
    Set dataSheet = ThisWorkbook.Worksheets("Data")
    lastRow = dataSheet.Cells(Rows.count, 7).End(xlUp).Row
    
    Set Rng = dataSheet.Range("G2:M" & lastRow)
    
    Dim orderArr() As Variant
    Dim itemArr() As Variant
    
    ReDim orderArr(1 To Rng.Rows.count)
    ReDim itemArr(1 To Rng.Rows.count)
    
    For i = 1 To Rng.Rows.count
        orderArr(i) = Rng.Cells(i, 1).Value
        For j = 2 To 5
            itemArr(i) = itemArr(i) & "," & Rng.Cells(i, j).Value
        Next j
        
        itemArr(i) = Right(itemArr(i), Len(itemArr(i)) - 1)
    Next i
    
    unqOrderArr = UniqueValues(orderArr)
    unqItemArr = UniqueValues(itemArr)
    
    Dim qnCount() As Integer
    ReDim qnCount(1 To UBound(unqItemArr))
    
    For i = LBound(itemArr) To UBound(itemArr)
        For j = LBound(unqItemArr) To UBound(unqItemArr)
            If itemArr(i) = unqItemArr(j) Then
                qnCount(j) = qnCount(j) + Rng.Cells(i, Rng.Columns.count).Value
                Exit For
            End If
        Next j
    Next i
    
    Dim itemsPerOrder() As Integer
    Dim countPerItem() As Integer
    Dim sumPerItem() As Integer
    
    ReDim itemsPerOrder(1 To UBound(unqOrderArr))
    ReDim countPerItem(1 To UBound(unqItemArr))
    ReDim sumPerItem(1 To UBound(unqItemArr))
    
    For i = LBound(unqOrderArr) To UBound(unqOrderArr)
        For j = LBound(orderArr) To UBound(orderArr) - 1
            If unqOrderArr(i) = orderArr(j) Then
                If itemArr(j) <> itemArr(j + 1) Then
                    itemsPerOrder(i) = itemsPerOrder(i) + 1
                End If
            End If
        Next j
    Next i
    
    itemsPerOrder(UBound(itemsPerOrder)) = itemsPerOrder(UBound(itemsPerOrder)) + 1
    
    For i = LBound(unqItemArr) To UBound(unqItemArr)
        For j = LBound(itemArr) To UBound(itemArr)
            If unqItemArr(i) = itemArr(j) Then
                countPerItem(i) = countPerItem(i) + Rng.Cells(j, Rng.Columns.count).Value
                sumPerItem(i) = sumPerItem(i) + Rng.Cells(j, Rng.Columns.count - 1).Value * Rng.Cells(j, Rng.Columns.count).Value
            End If
        Next j
    Next i

    Set reportSheet = ThisWorkbook.Worksheets("Report")
    Dim cRow As Integer
    Dim dsRow As Integer
    Dim cpiIndex As Integer
    Dim arr() As String
    
    cRow = 2
    dsRow = 1
    cpiIndex = 1

    For i = LBound(unqOrderArr) To UBound(unqOrderArr)
        reportSheet.Cells(cRow, 1) = i
        reportSheet.Cells(cRow, 2) = unqOrderArr(i)
        cRow = cRow + 1
        For j = 1 To itemsPerOrder(i)
            For k = 1 To 4
                arr = Split(unqItemArr(cpiIndex), ",")
                reportSheet.Cells(cRow, k + 1) = arr(k - 1)
            Next k
            reportSheet.Cells(cRow, 6) = "cm"
            reportSheet.Cells(cRow, 12) = countPerItem(cpiIndex)
            reportSheet.Cells(cRow, 13) = sumPerItem(cpiIndex)
            Dim count As Integer
            Dim itmCount As Integer
            count = 0
            itmCount = 0
            While itmCount < countPerItem(cpiIndex)
                For k = 1 To 5
                    If Rng.Cells(dsRow, Rng.Columns.count).Value <= 10 Then
                        reportSheet.Cells(cRow, k + 6).Value = Rng.Cells(dsRow, Rng.Columns.count - 1).Value
                        count = count + 1
                        itmCount = itmCount + 1
                        If count = Rng.Cells(dsRow, Rng.Columns.count).Value Then
                            count = 0
                            dsRow = dsRow + 1
                        End If
                        If itmCount Mod 5 = 0 Then
                            cRow = cRow + 1
                        End If
                        If itmCount = countPerItem(cpiIndex) Then
                            Exit For
                        End If
                    Else
                        reportSheet.Range(Cells(cRow, 7), Cells(cRow, 8)).Merge
                        reportSheet.Cells(cRow, 7) = Rng.Cells(dsRow, Rng.Columns.count - 1).Value & " x " & Rng.Cells(dsRow, Rng.Columns.count).Value
                        k = k + 1
                        itmCount = itmCount + Rng.Cells(dsRow, Rng.Columns.count).Value
                        dsRow = dsRow + 1
                    End If
                Next k
            Wend
            cpiIndex = cpiIndex + 1
            cRow = cRow + 1
        Next j
    Next i
    
    reportSheet.Range(Cells(cRow + 1, 1), Cells(cRow + 1, 11)).Merge
    reportSheet.Cells(cRow + 1, 1).Value = "Total"
    
    For i = 3 To cRow - 1
        reportSheet.Cells(cRow + 1, 12).Value = reportSheet.Cells(cRow + 1, 12).Value + reportSheet.Cells(i, 12).Value
        reportSheet.Cells(cRow + 1, 13).Value = reportSheet.Cells(cRow + 1, 13).Value + reportSheet.Cells(i, 13).Value
    Next i
    
End Sub

Afterward, you can change the format of the cells if you require. I have also attached my Excel.xlsm file below. Hopefully, this will be satisfactory for your requirements. Let us know your feedback.

Regards,
Seemanto Saha
ExcelDemy

 

[Jasper.Muduvhadzi]

My VBA is Disabled. Any one who knows how to enable Macros here. I have tried to enable it on trust center but still getting the message showing that Microsoft has disabled my macro.

 

[Seemanto Saha]

Hello Jasper.Muduvhadzi,
If you have tried to enable macros in the Trust Center but are still receiving a message that your macros are disabled, you can try the following methods as a solution:

1. Enable macros for a specific workbook:
   • Open the xlsm type Excel workbook.
   • In the Message Bar that appears at the top of the screen, click "Enable Content".
   • Save the workbook and try running your macro again.
2. Check if the macro security level is set to "Disable all macros without notification"
   • Open the macro-enabled workbook.
   • In the Message Bar that appears at the top of the screen, click "Enable Content".
   • If you do not see the Message Bar, go to File > Options > Trust Center > Trust Center Settings, select "Macro Settings" and make sure "Enable all macros" or "Disable all macros with notification" is selected.
   • Save the workbook and try running your macro again.

Hopefully, this will provide a remedy to your problem. let us know your feedback.