从列中选择数据并创建报告

Question

我想创建一个报告，需要从 A 列、B 列、C 列中选择一些数据并将它们插入到 F 列中。我附上报告的一部分作为示例，我需要通过以下方式填充 F 列VBA 代码（绿色单元格作为字符串）。

有人可以帮助我吗？

Answer 1

通过嵌套字典处理唯一性

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

亲爱的VBasic2008，太棒了。你的代码正是我需要的。 我试图开发它来覆盖我的细节。但我做不到。我有一个请求 ： D 列、E 列是“计数”和“重量”。我想添加与括号中的数据和鳕鱼（在绿色区域的H列中）相对应的计数求和和权重求和，就像sample.jpg

第二个要求是G列包含可用的唯一代码，不需要再次创建。 vba cod可以创建绿色区域吗？有可能吗？