Excel VBA 代码：将特定列中的所有相似项目合并到单行中，并将其他详细信息连接到单个单元格中

问题描述 投票：0回答：1

在此输入图片描述

上面的屏幕截图是我当前的输出，但我不确定如何将输出更改为下面的屏幕截图：

在此输入图片描述

对于这个实例，第一个屏幕截图中的成分“洋葱”位于多行中，现在我想要像第二个屏幕截图中那样的输出，其中成分“洋葱”现在位于单行中，但其他列正在像膳食类型和特定列一样串联。

以下是我当前的VBA代码：

Sub FilterAndCopyData()
Dim wsMenu As Worksheet
Dim wsDishes As Worksheet
Dim wsIngredients As Worksheet
Dim wsTemp As Worksheet
Dim lastRowDishes As Long
Dim lastRowIngredients As Long
Dim i As Long, j As Long, k As Long
Dim results As Collection
' Set references to the worksheets
Set wsMenu = ThisWorkbook.Sheets("Menu")
Set wsDishes = ThisWorkbook.Sheets("Dishes Database")
Set wsTemp = ThisWorkbook.Sheets("Market List")
' Check if Ingredient Database sheet exists
On Error Resume Next
Set wsIngredients = ThisWorkbook.Sheets("Ingredients Database")
On Error GoTo 0
If wsIngredients Is Nothing Then
    MsgBox "Worksheet 'Ingredient Database' not found.", vbExclamation
    Exit Sub
End If


    ' Clear specified ranges in "Market List"
With Sheets("Market List")
    .Range("H4:H8").ClearContents
    .Range("E10:I16").ClearContents
    .Range("C20:I24").ClearContents
    .Range("C29:I33").ClearContents
    .Range("C38:I42").ClearContents
End With

' Copy data from "Menu" and paste it into "Market List"
With Sheets("Menu")
    .Range("F6:F8").Copy
End With

With Sheets("Market List")
    .Range("H4:H6").PasteSpecial Paste:=xlPasteValues
End With

' Clear the clipboard
Application.CutCopyMode = False

' Copy meal data based on conditions
Dim mealData As Range
Set mealData = Sheets("Menu").Range("D11", Sheets("Menu").Range("D11").End(xlDown))

Dim mealCell As Range
Dim breakfast As String, amSnacks As String, lunch As String
Dim pmSnacks As String, cocktails As String, dinner As String, midnight As String

breakfast = ""
amSnacks = ""
lunch = ""
pmSnacks = ""
cocktails = ""
dinner = ""
midnight = ""

For Each mealCell In mealData
    Select Case mealCell.Value
        Case "AM Snacks"
            If amSnacks <> "" Then amSnacks = amSnacks & ", "
            amSnacks = amSnacks & mealCell.Offset(0, 1).Value
        Case "Breakfast"
            If breakfast <> "" Then breakfast = breakfast & ", "
            breakfast = breakfast & mealCell.Offset(0, 1).Value
        Case "Lunch"
            If lunch <> "" Then lunch = lunch & ", "
            lunch = lunch & mealCell.Offset(0, 1).Value
        Case "PM Snacks"
            If pmSnacks <> "" Then pmSnacks = pmSnacks & ", "
            pmSnacks = pmSnacks & mealCell.Offset(0, 1).Value
        Case "Cocktails"
            If cocktails <> "" Then cocktails = cocktails & ", "
            cocktails = cocktails & mealCell.Offset(0, 1).Value
        Case "Dinner"
            If dinner <> "" Then dinner = dinner & ", "
            dinner = dinner & mealCell.Offset(0, 1).Value
        Case "Midnight"
            If midnight <> "" Then midnight = midnight & ", "
            midnight = midnight & mealCell.Offset(0, 1).Value
    End Select
Next mealCell

' Replace empty strings with "None"
If amSnacks = "" Then amSnacks = "None"
If breakfast = "" Then breakfast = "None"
If lunch = "" Then lunch = "None"
If pmSnacks = "" Then pmSnacks = "None"
If cocktails = "" Then cocktails = "None"
If dinner = "" Then dinner = "None"
If midnight = "" Then midnight = "None"
    ' Paste the concatenated meal data into "Market List"
    With Sheets("Market List")
        .Range("E10").Value = amSnacks
        .Range("E11").Value = breakfast
        .Range("E12").Value = lunch
        .Range("E13").Value = pmSnacks
        .Range("E14").Value = cocktails
        .Range("E15").Value = dinner
        .Range("E16").Value = midnight
    End With
    
    
' Find the last row with data in Column B of Dishes Database sheet
lastRowDishes = wsDishes.Cells(wsDishes.Rows.Count, "B").End(xlUp).Row
' Find the last row with data in Column A of Ingredient Database sheet
lastRowIngredients = wsIngredients.Cells(wsIngredients.Rows.Count, "A").End(xlUp).Row
' Initialize the collection to store the results
Set results = New Collection
' Loop through each value in Menu Column C11, D11, E11, and F8 onwards
For i = 11 To wsMenu.Cells(wsMenu.Rows.Count, "C").End(xlUp).Row
    Dim menuValueC As Variant
    Dim menuValueD As Variant
    menuValueC = wsMenu.Cells(i, "C").Value
    menuValueD = wsMenu.Cells(i, "D").Value
    ' Loop through each value in Menu Column E11 onwards
    For j = 11 To wsMenu.Cells(wsMenu.Rows.Count, "E").End(xlUp).Row
        Dim menuValueE As Variant
        menuValueE = wsMenu.Cells(j, "E").Value
        ' Loop through Dishes Database to find matching values
        For k = 6 To lastRowDishes
            If wsDishes.Cells(k, "A").Value = menuValueC And wsDishes.Cells(k, "B").Value = menuValueE Then
                ' Find corresponding values in Ingredient Database
                Dim dishName As String
                dishName = wsDishes.Cells(k, "C").Value
                ' Search for dishName in Ingredient Database
                Dim l As Long
                For l = 4 To lastRowIngredients
                    If wsIngredients.Cells(l, "A").Value = dishName Then
                        ' Add unique results to the collection
                        Dim key As String
                        key = dishName & "_" & menuValueD & "_" & menuValueE
                        On Error Resume Next
                        results.Add Array(dishName, wsDishes.Cells(k, "D").Value, wsIngredients.Cells(l, "C").Value, wsIngredients.Cells(l, "D").Value, menuValueD, menuValueE, wsIngredients.Cells(l, "B").Value), key
                        On Error GoTo 0
                        Exit For ' Exit inner loop once a match is found
                    End If
                Next l
            End If
        Next k
    Next j
Next i

' Write the results to Market List starting from row 2
Dim resultRow As Long


Dim m As Long
Dim colMarketList As Integer
Dim dblSubtotal As Double
Dim dblGrandTotal As Double

resultRow = 18 'reference row for Market List start or items

' Clear previous data in Market List starting from row 2
wsTemp.Rows(resultRow & ":" & wsTemp.Rows.Count).Clear
colMarketList = 2

' Create the Headers
' MEAT AND SEAFOOD
With wsTemp
    .Range("A" & resultRow).Interior.Color = RGB(153, 255, 153)
    .Range("K" & resultRow).Interior.Color = RGB(153, 255, 153)
End With
wsTemp.Cells(resultRow, colMarketList + 1).Value = "MEAT AND SEAFOOD"
With wsTemp.Range(wsTemp.Cells(resultRow, colMarketList + 1).Address & ":" & wsTemp.Cells(resultRow, colMarketList + 7).Address)
    .Interior.Color = RGB(175, 169, 170)
    .Font.Bold = True
End With

resultRow = resultRow + 1
With wsTemp
    .Cells(resultRow, colMarketList + 1).Value = "Ingredients"
    .Cells(resultRow, colMarketList + 2).Value = "Quantity"
    .Cells(resultRow, colMarketList + 3).Value = "UoM"
    .Cells(resultRow, colMarketList + 4).Value = "Cost per Unit"
    .Cells(resultRow, colMarketList + 5).Value = "Total Cost"
    .Cells(resultRow, colMarketList + 6).Value = "Meal Type"
    .Cells(resultRow, colMarketList + 7).Value = "Particular"
End With
With wsTemp.Range(wsTemp.Cells(resultRow, colMarketList + 1).Address & ":" & wsTemp.Cells(resultRow, colMarketList + 7).Address)
    .Interior.Color = RGB(226, 239, 218)
End With
With wsTemp
    .Range("A" & resultRow).Interior.Color = RGB(153, 255, 153)
    .Range("K" & resultRow).Interior.Color = RGB(153, 255, 153)
End With

resultRow = resultRow + 1
For m = 1 To results.Count
    If results(m)(6) = "MEAT AND SEAFOOD" Then
        wsTemp.Cells(resultRow, colMarketList + 1).Value = results(m)(0) ' Dish Name from Dishes Database
        wsTemp.Cells(resultRow, colMarketList + 2).Value = results(m)(1) * Sheets("Market List").Range("H6").Value ' Ingredient Column D from Ingredient Database
        wsTemp.Range(wsTemp.Cells(resultRow, colMarketList + 2).Address).NumberFormat = "#,##0.00"
        wsTemp.Cells(resultRow, colMarketList + 3).Value = results(m)(2) ' Ingredient Column C from Ingredient Database
        wsTemp.Cells(resultRow, colMarketList + 4).Value = results(m)(3)  ' Column D from Dishes Database"
        
        wsTemp.Range(wsTemp.Cells(resultRow, colMarketList + 5).Address).NumberFormat = "#,##0.00"
        wsTemp.Cells(resultRow, colMarketList + 5).Formula = Replace("=D{var}*F{var}", "{var}", CStr(resultRow))
        
        'wsTemp.Range(wsTemp.Cells(resultRow, colMarketList + 5).Address).Formula = Replace("=D{var}*F{var}", "{var}", resultRow) ' Column D from Dishes Database"
        wsTemp.Cells(resultRow, colMarketList + 6).Value = results(m)(4) ' Menu Column D value
        wsTemp.Cells(resultRow, colMarketList + 7).Value = results(m)(5) ' Menu Column E11 onwards value
        
        With wsTemp.Range(wsTemp.Cells(resultRow, colMarketList + 1).Address & ":" & wsTemp.Cells(resultRow, colMarketList + 7).Address).Borders
            .LineStyle = 1
            .Color = RGB(115, 114, 112)
        End With
        With wsTemp
            .Range("A" & resultRow).Interior.Color = RGB(153, 255, 153)
            .Range("K" & resultRow).Interior.Color = RGB(153, 255, 153)
        End With
        
        dblSubtotal = dblSubtotal + wsTemp.Cells(resultRow, colMarketList + 5)
        resultRow = resultRow + 1
    End If
Next m

wsTemp.Cells(resultRow, colMarketList + 4).Value = "Subtotal"
wsTemp.Cells(resultRow, colMarketList + 5).Value = dblSubtotal
wsTemp.Cells(resultRow, colMarketList + 5).NumberFormat = "#,##0.00"
dblGrandTotal = dblGrandTotal + dblSubtotal
With wsTemp
    .Range("A" & resultRow).Interior.Color = RGB(153, 255, 153)
    .Range("K" & resultRow).Interior.Color = RGB(153, 255, 153)
End With
resultRow = resultRow + 1
With wsTemp
    .Range("A" & resultRow).Interior.Color = RGB(153, 255, 153)
    .Range("K" & resultRow).Interior.Color = RGB(153, 255, 153)
End With
resultRow = resultRow + 1
With wsTemp
    .Range("A" & resultRow).Interior.Color = RGB(153, 255, 153)
    .Range("K" & resultRow).Interior.Color = RGB(153, 255, 153)
End With

' Create the Headers
' VEGETABLES AND FRUITS
wsTemp.Cells(resultRow, colMarketList + 1).Value = "VEGETABLE AND FRUITS"
With wsTemp.Range(wsTemp.Cells(resultRow, colMarketList + 1).Address & ":" & wsTemp.Cells(resultRow, colMarketList + 7).Address)
    .Interior.Color = RGB(175, 169, 170)
    .Font.Bold = True
End With

resultRow = resultRow + 1
With wsTemp
    .Cells(resultRow, colMarketList + 1).Value = "Ingredients"
    .Cells(resultRow, colMarketList + 2).Value = "Quantity"
    .Cells(resultRow, colMarketList + 3).Value = "UoM"
    .Cells(resultRow, colMarketList + 4).Value = "Cost per Unit"
    .Cells(resultRow, colMarketList + 5).Value = "Total Cost"
    .Cells(resultRow, colMarketList + 6).Value = "Meal Type"
    .Cells(resultRow, colMarketList + 7).Value = "Particular"
End With
With wsTemp.Range(wsTemp.Cells(resultRow, colMarketList + 1).Address & ":" & wsTemp.Cells(resultRow, colMarketList + 7).Address)
    .Interior.Color = RGB(226, 239, 218)
End With
With wsTemp
    .Range("A" & resultRow).Interior.Color = RGB(153, 255, 153)
    .Range("K" & resultRow).Interior.Color = RGB(153, 255, 153)
End With

resultRow = resultRow + 1
For m = 1 To results.Count
    If results(m)(6) = "VEGETABLE AND FRUITS" Then
        wsTemp.Cells(resultRow, colMarketList + 1).Value = results(m)(0) ' Dish Name from Dishes Database
        wsTemp.Cells(resultRow, colMarketList + 2).Value = results(m)(1) * Sheets("Market List").Range("H6").Value ' Ingredient Column D from Ingredient Database
        wsTemp.Range(wsTemp.Cells(resultRow, colMarketList + 2).Address).NumberFormat = "#,##0.00"
        wsTemp.Cells(resultRow, colMarketList + 3).Value = results(m)(2) ' Ingredient Column C from Ingredient Database
        wsTemp.Cells(resultRow, colMarketList + 4).Value = results(m)(3)  ' Column D from Dishes Database"
        
        wsTemp.Range(wsTemp.Cells(resultRow, colMarketList + 5).Address).NumberFormat = "#,##0.00"
        wsTemp.Cells(resultRow, colMarketList + 5).Formula = Replace("=D{var}*F{var}", "{var}", CStr(resultRow))
        
        'wsTemp.Range(wsTemp.Cells(resultRow, colMarketList + 5).Address).Formula = Replace("=D{var}*F{var}", "{var}", resultRow) ' Column D from Dishes Database"
        wsTemp.Cells(resultRow, colMarketList + 6).Value = results(m)(4) ' Menu Column D value
        wsTemp.Cells(resultRow, colMarketList + 7).Value = results(m)(5) ' Menu Column E11 onwards value
        
        With wsTemp.Range(wsTemp.Cells(resultRow, colMarketList + 1).Address & ":" & wsTemp.Cells(resultRow, colMarketList + 7).Address).Borders
            .LineStyle = 1
            .Color = RGB(115, 114, 112)
        End With
        With wsTemp
            .Range("A" & resultRow).Interior.Color = RGB(153, 255, 153)
            .Range("K" & resultRow).Interior.Color = RGB(153, 255, 153)
        End With
        
        dblSubtotal = dblSubtotal + wsTemp.Cells(resultRow, colMarketList + 5).Value
        resultRow = resultRow + 1
    End If
Next m

wsTemp.Cells(resultRow, colMarketList + 4).Value = "Subtotal"
wsTemp.Cells(resultRow, colMarketList + 5).Value = dblSubtotal
wsTemp.Cells(resultRow, colMarketList + 5).NumberFormat = "#,##0.00"
dblGrandTotal = dblGrandTotal + dblSubtotal
With wsTemp
    .Range("A" & resultRow).Interior.Color = RGB(153, 255, 153)
    .Range("K" & resultRow).Interior.Color = RGB(153, 255, 153)
End With
resultRow = resultRow + 1
With wsTemp
    .Range("A" & resultRow).Interior.Color = RGB(153, 255, 153)
    .Range("K" & resultRow).Interior.Color = RGB(153, 255, 153)
End With
resultRow = resultRow + 1
With wsTemp
    .Range("A" & resultRow).Interior.Color = RGB(153, 255, 153)
    .Range("K" & resultRow).Interior.Color = RGB(153, 255, 153)
End With

' Create the Headers
' GROCERY ITEMS
wsTemp.Cells(resultRow, colMarketList + 1).Value = "GROCERY ITEMS"
With wsTemp.Range(wsTemp.Cells(resultRow, colMarketList + 1).Address & ":" & wsTemp.Cells(resultRow, colMarketList + 7).Address)
    .Interior.Color = RGB(175, 169, 170)
    .Font.Bold = True
End With

resultRow = resultRow + 1
With wsTemp
    .Cells(resultRow, colMarketList + 1).Value = "Ingredients"
    .Cells(resultRow, colMarketList + 2).Value = "Quantity"
    .Cells(resultRow, colMarketList + 3).Value = "UoM"
    .Cells(resultRow, colMarketList + 4).Value = "Cost per Unit"
    .Cells(resultRow, colMarketList + 5).Value = "Total Cost"
    .Cells(resultRow, colMarketList + 6).Value = "Meal Type"
    .Cells(resultRow, colMarketList + 7).Value = "Particular"
End With
With wsTemp.Range(wsTemp.Cells(resultRow, colMarketList + 1).Address & ":" & wsTemp.Cells(resultRow, colMarketList + 7).Address)
    .Interior.Color = RGB(226, 239, 218)
End With
With wsTemp
    .Range("A" & resultRow).Interior.Color = RGB(153, 255, 153)
    .Range("K" & resultRow).Interior.Color = RGB(153, 255, 153)
End With

resultRow = resultRow + 1
For m = 1 To results.Count
    If results(m)(6) = "GROCERY ITEMS" Then
        wsTemp.Cells(resultRow, colMarketList + 1).Value = results(m)(0) ' Dish Name from Dishes Database
        wsTemp.Cells(resultRow, colMarketList + 2).Value = results(m)(1) * Sheets("Market List").Range("H6").Value ' Ingredient Column D from Ingredient Database
        wsTemp.Range(wsTemp.Cells(resultRow, colMarketList + 2).Address).NumberFormat = "#,##0.00"
        wsTemp.Cells(resultRow, colMarketList + 3).Value = results(m)(2) ' Ingredient Column C from Ingredient Database
        wsTemp.Cells(resultRow, colMarketList + 4).Value = results(m)(3)  ' Column D from Dishes Database"
        
        wsTemp.Range(wsTemp.Cells(resultRow, colMarketList + 5).Address).NumberFormat = "#,##0.00"
        wsTemp.Cells(resultRow, colMarketList + 5).Formula = Replace("=D{var}*F{var}", "{var}", CStr(resultRow))

        
        'wsTemp.Range(wsTemp.Cells(resultRow, colMarketList + 5).Address).Formula = Replace("=D{var}*F{var}", "{var}", resultRow) ' Column D from Dishes Database"
        wsTemp.Cells(resultRow, colMarketList + 6).Value = results(m)(4) ' Menu Column D value
        wsTemp.Cells(resultRow, colMarketList + 7).Value = results(m)(5) ' Menu Column E11 onwards value
        
        With wsTemp.Range(wsTemp.Cells(resultRow, colMarketList + 1).Address & ":" & wsTemp.Cells(resultRow, colMarketList + 7).Address).Borders
            .LineStyle = 1
            .Color = RGB(115, 114, 112)
        End With
        With wsTemp
            .Range("A" & resultRow).Interior.Color = RGB(153, 255, 153)
            .Range("K" & resultRow).Interior.Color = RGB(153, 255, 153)
        End With
        
        dblSubtotal = dblSubtotal + wsTemp.Cells(resultRow, colMarketList + 5).Value
        resultRow = resultRow + 1
    End If
Next m

wsTemp.Cells(resultRow, colMarketList + 4).Value = "Subtotal"
wsTemp.Cells(resultRow, colMarketList + 5).Value = dblSubtotal
wsTemp.Cells(resultRow, colMarketList + 5).NumberFormat = "#,##0.00"
dblGrandTotal = dblGrandTotal + dblSubtotal
With wsTemp
    .Range("A" & resultRow).Interior.Color = RGB(153, 255, 153)
    .Range("K" & resultRow).Interior.Color = RGB(153, 255, 153)
End With
resultRow = resultRow + 1
With wsTemp
    .Range("A" & resultRow).Interior.Color = RGB(153, 255, 153)
    .Range("K" & resultRow).Interior.Color = RGB(153, 255, 153)
End With
resultRow = resultRow + 1
With wsTemp
    .Range("A" & resultRow).Interior.Color = RGB(153, 255, 153)
    .Range("K" & resultRow).Interior.Color = RGB(153, 255, 153)
End With
wsTemp.Cells(resultRow, colMarketList + 4).Value = "Grand Total"
wsTemp.Cells(resultRow, colMarketList + 5).Value = dblGrandTotal
wsTemp.Cells(resultRow, colMarketList + 5).NumberFormat = "#,##0.00"

   
' Navigate to "Market List" worksheet
wsTemp.Activate
MsgBox "Data copied successfully to Market List.", vbInformation

结束子

excel vba
1个回答
0
投票

您没有回答我的澄清问题...所以，在下一段代码中我将尝试展示如何将第一张图片内容转换为第二张图片。它使用字典（首先确定独特的成分及其对应的元素）和数组，让代码仅在内存中运行并且速度很快。请**注意将退回的表格修改为适当的表格。现在，它返回到下一张纸（相对于活动纸）。该代码假设要处理的范围从活动工作表中的“A1”开始。：

Sub UniqueIngredientsCumullative()
 Dim ws As Worksheet, wsRet As Worksheet, lastR As Long, arr, arrIt, arrFin
 Dim i As Long, j As Long, k As Long, dict As Object
 
 Set ws = ActiveSheet 'use here the sheet you need
 Set wsRet = ws.Next 'use here your sheet where to return the processed result
 lastR = ws.Range("A" & ws.rows.count).End(xlUp).row
 
 arr = ws.Range("A2:G" & lastR).Value2 'place the range in an array for faster processing
 
 'load the dictionary:
 Set dict = CreateObject("Scripting.Dictionary") 'set the necessary dictionary
 For i = 1 To UBound(arr)
    If Not dict.Exists(arr(i, 1)) Then 'if the dictionary key does not exist
        ReDim arrIt(5)                 'redim the intermediary array
        For j = 0 To UBound(arrIt): arrIt(j) = arr(i, j + 2): Next j 'load the data in the array
        dict.Add arr(i, 1), arrIt      'place the array as dictionary item
    Else
       Erase arrIt 'clear the array (also redimmed dimensions...)
       arrIt = dict(arr(i, 1)) 'extract the array item, to be modified
       'process the rest of array elements as described in your question:
       arrIt(0) = arrIt(0) + arr(i, 2): arrIt(2) = arrIt(2) + arr(i, 4)
       arrIt(3) = arrIt(3) + arr(i, 5): arrIt(4) = arrIt(4) & ", " & arr(i, 6)
       arrIt(5) = arrIt(5) & ", " & arr(i, 7)
       dict(arr(i, 1)) = arrIt 'place back the modified array as dict item
    End If
 Next i
 
 'place the dictionary data in the final array (arrFin):
 ReDim arrFin(1 To dict.count, 1 To UBound(arr))
 For i = 0 To dict.count - 1 'iterate between the dictionary elements (base 0)
    k = k + 1                     'initialize and increment the array rows
    arrIt = dict.Items()(i)       'extract the dict item in an array, to be processed
    arrFin(k, 1) = dict.keys()(i) 'place the key in the first  final array column
    For j = 0 To UBound(arrIt): arrFin(k, j + 2) = arrIt(j): Next j 'place the next items on the next columns
 Next i
 
 'Drop the final array content, at once:
 wsRet.Range("A1").Resize(UBound(arrFin), UBound(arrFin, 2)).Value2 = arrFin
 
 MsgBox "Ready...": wsRet.Activate
End Sub

请在测试后发送一些反馈。

最新问题
© www.soinside.com 2019 - 2024. All rights reserved.