Question

我有一个列card_id和另一个列日期现在，对于每列，有b列的多个值

例如：

   column a  column b

   1         10/12/2011    
   1         10/01/2014  
   2         01/02/2013    
   2         01/03/2014   
   2         02/03/2014  
   2         10/09/2014
   3         05/06/2012
   3         02/03/2013

我希望这些显示为：

列a

                date 1        date 2       date 3       date 4
   1         10/12/2011    10/01/2014   -
   2         01/02/2013    01/03/2014   02/03/2014  10/09/2014
   3         05/06/2012    02/03/2013

Answer 1

我可能只有你的宏，这里是：

Sub ConsolidateRows_MultipleColumns()
'takes rows and consolidate one or many cells, based on one or many cells matching with above or below rows.

Dim lastRow As Long, i As Long, j As Long
Dim colMatch As Variant, colConcat As Variant

'**********PARAMETERS TO UPDATE****************
Const strMatch As String = "A"    'columns that need to match for consolidation, separated by commas
Const strConcat As String = "B"     'columns that need consolidating, separated by commas - should be rightmost column
Const strSep As String = "|"     'string that will separate the consolidated values, use a value that's not in the consolidated strings
'*************END PARAMETERS*******************

application.ScreenUpdating = False 'disable ScreenUpdating to avoid screen flashes

colMatch = Split(strMatch, ",")
colConcat = Split(strConcat, ",")

lastRow = range("A" & Rows.Count).End(xlUp).Row 'get last row

For i = lastRow To 2 Step -1 'loop from last Row to one

    For j = 0 To UBound(colMatch)
        If Cells(i, colMatch(j)) <> Cells(i - 1, colMatch(j)) Then GoTo nxti
    Next

    For j = 0 To UBound(colConcat)
        Cells(i - 1, colConcat(j)) = Cells(i - 1, colConcat(j)) & strSep & Cells(i, colConcat(j))
    Next

    Rows(i).Delete

nxti:
Next

Columns(strConcat).TextToColumns Destination:=Columns(strConcat).Cells(1, 1), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
    :=strSep

application.ScreenUpdating = True 'reenable ScreenUpdating
End Sub

条件转置 - Excel

1 个答案: