select data from columns and create a report

Question

enter image description here I want to create a report and a need to select some data from column A , column B , column C and insert them on column F. I attach a part of my report as sample and I need to fill column F via vba code (green cell as string).

anyone can help me?

Answer 1

Handle Unique By Nesting Dictionaries

Sub TransformData()
    
    ' Define constants.
    
    Const SRC_SHEET_NAME As String = "Sheet1"
    Const SRC_FIRST_CELL As String = "A1"
    Const DST_SHEET_NAME As String = "Sheet1"
    Const DST_FIRST_CELL As String = "E1"
    Const DST_DATE_FORMAT As String = "mm\/dd\/yyyy"
    Const DST_DATE_DELIMITER As String = "; "
    Const DST_TYPE_DELIMITER As String = ", "
    Const DST_DATE_TYPE_DELIMITER As String = "/"
    Const DST_TYPE_LEFT_WRAPPER As String = " ("
    Const DST_TYPE_RIGHT_WRAPPER As String = ")"
    ' Reference the workbook.
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Write to source array.
    
    ' Reference the objects.
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET_NAME)
    Dim srg As Range: Set srg = sws.Range(SRC_FIRST_CELL).CurrentRegion
    ' Write.
    Dim sData() As Variant: sData = srg.Value
    
    ' Write to the dictionary.

    ' Define.
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary") ' number
    ' Declare additional variables.
    Dim r As Long, c As Long, cVal As Variant, dVal As Variant, tVal As Variant
    ' Write.
    For r = 2 To UBound(sData, 1)
        cVal = sData(r, 1)
        If Not dict.Exists(cVal) Then
            Set dict(cVal) = CreateObject("Scripting.Dictionary") 'date
        End If
        dVal = Format(sData(r, 2), DST_DATE_FORMAT)
        If Not dict(cVal).Exists(dVal) Then
            Set dict(cVal)(dVal) = CreateObject("Scripting.Dictionary") ' string
            dict(cVal)(dVal).CompareMode = vbTextCompare
        End If
        tVal = sData(r, 3)
        If Not dict(cVal)(dVal).Exists(tVal) Then
            dict(cVal)(dVal)(tVal) = Empty
        End If
    Next r
    
    ' Write to the destination array.
    
    ' Define (initialize).
    Dim dData() As Variant: ReDim dData(1 To dict.Count + 1, 1 To 2)
    r = 1
    ' Write headers.
    dData(1, 1) = sData(1, 1)
    dData(1, 2) = sData(1, 2) & DST_DATE_TYPE_DELIMITER & sData(1, 3)
    ' Declare additional variables.
    Dim cKey As Variant, dKey As Variant, dStr As String
    ' Write data.
    For Each cKey In dict.Keys
        r = r + 1
        dData(r, 1) = cKey
        For Each dKey In dict(cKey).Keys
            dStr = dStr & DST_DATE_DELIMITER & dKey & DST_TYPE_LEFT_WRAPPER _
                & Join(dict(cKey)(dKey).Keys, DST_TYPE_DELIMITER) _
                & DST_TYPE_RIGHT_WRAPPER
        Next dKey
        dStr = Right(dStr, Len(dStr) - Len(DST_DATE_DELIMITER))
        dData(r, 2) = dStr
        dStr = vbNullString
    Next cKey
    
    ' Write to the destination range.
    
    ' Reference the objects.
    Dim dws As Worksheet: Set dws = wb.Sheets(DST_SHEET_NAME)
    Dim dfcell As Range: Set dfcell = sws.Range(DST_FIRST_CELL)
    Dim drg As Range: Set drg = dfcell.Resize(r, 2)
    ' Write.
    drg.Value = dData
    ' Clear below.
    drg.Resize(dws.Rows.Count - drg.Row - r + 1).Offset(r).Clear
    ' Format.
    With drg
        .Rows(1).Font.Bold = True
        .EntireColumn.AutoFit
    End With

    ' Inform.
    
    MsgBox "Data transformed.", vbInformation

End Sub

Answer 2

thaaaaaanks a lot dear VBasic2008. your code was exactly that I need . I tried to develop it to cover my details. But I can't do it. I have a request : columns D , E are "count" and "weight" . I want to add count summation and weight summation corresponding to a data and cod in bracket(in column H at green area) like a sample.jpg

second request is that column G include unique codes are available and its not need to create again. can the vba cod, just create green area? is it possible?