Excel VBA合并行而不会丢失

Question

我需要循环浏览Excel工作表上的行，然后将它们合并。 基本上，我一次比较第1行，如果它们满足参数，则我将它们合并（合并？）。

我想让它在哪里，如果数据匹配，我们什么也不做；如果为空，我们填补空白；如果数据不同，则用逗号分隔符将其连接起来。 以下是我正在努力的代码部分。 这是我第一次进行VBA，我试图找到解决方案，但是已经连续几天运转了。

非常感谢您的任何帮助。

编辑

用户@ Ron Rosenfeld抓住了我犯的一个错误，这可能会增加一些混乱。 我在上一段中指的参数是代码中的if语句。 我想查看单元票号是否与它下面的单元格值匹配，以及单元格日期是否与它下面的单元格值匹配。 如果这两个值都匹配，那么我想尽可能优雅地合并数据。

我要这个

成为

 For i = 2 To myRows.Count

'compare the current row to the one below it while matches are found. if the row under it is no longer a match then exit the loop

Do While doneComparing = False

If Cells(i, ticketNumberCell.Column).Value = Cells(i, ticketNumberCell.Column).Offset(1, 0).Value And Cells(i, dateCell.Column).Value = Cells(i, dateCell.Column).Offset(1, 0).Value Then
    'in here we merge, above we do our comparison
    'the below code is exceptionally slow. we need to speed it up or else this will not work.


'find a another way to merge since this doesnt do correctly anyway. The if statement is fine

'               For b = 1 To ColumnsCount
'                   Cells(i, b).Value = Cells(i, b).Offset(1, 0).Value '+ Cells(i, b).Value
'               Next
'                Rows(i).Offset(1, 0).Delete shift:=xlShiftUp
'
' Else
'     doneComparing = True

  End If
  Loop

'reset the flag for the next row
    doneComparing = False

  Next i

Answer 1

这是我在上面的评论中所指的快速而肮脏的示例。 我不知道数据代表什么，所以我只把类叫做“ RenameMe”。 这是类属性的样板代码：

'In RenameMe.cls
Option Explicit

Private mCounty As String
Private mDate As Date
Private mCode As String
Private mDescription As String
Private mTicket As String
Private mType As String

Public Property Let County(inValue As String)
    mCounty = inValue
End Property

Public Property Get County() As String
    County = mCounty
End Property

Public Property Let RecordDate(inValue As Date)
    mDate = inValue
End Property

Public Property Get RecordDate() As Date
    RecordDate = mDate
End Property

Public Property Let Code(inValue As String)
    mCode = inValue
End Property

Public Property Get Code() As String
    Code = mCode
End Property

Public Property Let Description(inValue As String)
    mDescription = inValue
End Property

Public Property Get Description() As String
    Description = mDescription
End Property

Public Property Let Ticket(inValue As String)
    mTicket = inValue
End Property

Public Property Get Ticket() As String
    Ticket = mTicket
End Property

Public Property Let RecordType(inValue As String)
    mType = inValue
End Property

Public Property Get RecordType() As String
    RecordType = mType
End Property

由于您将票证和日期视为不同记录的标准，因此这是一个简单的“哈希”函数，可根据该函数生成唯一键：

'Also in RenameMe.cls
Public Property Get Hash() As String
    Hash = Ticket & CLng(Date)
End Property

最后是加载和组合的方法：

'Also in RenameMe.cls
Public Sub LoadRecord(sheet As Worksheet, loadRow As Long)
    County = sheet.Cells(loadRow, 1).Value
    RecordDate = sheet.Cells(loadRow, 2).Value
    Code = sheet.Cells(loadRow, 3).Value
    Description = sheet.Cells(loadRow, 4).Value
    Ticket = sheet.Cells(loadRow, 5).Value
    RecordType = sheet.Cells(loadRow, 6).Value
End Sub

Public Sub WriteRecord(sheet As Worksheet, writeRow As Long)
    sheet.Cells(writeRow, 1).Value = County
    sheet.Cells(writeRow, 2).Value = RecordDate
    sheet.Cells(writeRow, 3).Value = Code
    sheet.Cells(writeRow, 4).Value = Description
    sheet.Cells(writeRow, 5).Value = Ticket
    sheet.Cells(writeRow, 6).Value = RecordType
End Sub

Public Sub CombineWith(other As RenameMe)
    If Code <> other.Code Then
        Code = Code & "," & other.Code
    End If
    If Description <> other.Description Then
        Description = Description & "," & other.Description
    End If
    If County <> other.County Then
        County = County & "," & other.County
    End If
    If RecordType <> other.RecordType Then
        RecordType = RecordType & "," & other.RecordType
    End If
End Sub

执行工作的实际代码只是将行集加载到具有散列作为键的Dictionary中，然后将键与现有记录匹配的行组合到字典中：

'In a module
Public Sub CombineRecords()
    Dim data As Worksheet
    Dim records As New Scripting.Dictionary

    Set data = ActiveSheet
    Dim i As Long, record As RenameMe
    For i = 2 To data.Range("A" & data.Rows.Count).End(xlUp).Row
        Set record = New RenameMe
        record.LoadRecord data, i
        If records.Exists(record.Hash) Then
            records.Item(record.Hash).CombineWith record
        Else
            records.Add record.Hash, record
        End If
    Next

    'Output to new sheet. Can easily wipe the current data
    'and replace too.
    Set data = data.Parent.Worksheets.Add

    Dim key As Variant
    i = 1
    For Each key In records
        records.Item(key).WriteRecord data, i
        i = i + 1
    Next
End Sub

Answer 2

这是有些不同的方法。 “唯一行”存储在字典中，但是如果应该将多个项目保留在同一行中，我们还可以在类中使用字典来存储多个项目。 完成后，将这些项目放在一起，并以逗号分隔的字符串。

另外，通过使用此方法，不需要预先对行进行排序。

可以使用内置的VBA Collection对象，但是我认为，尤其是对于这么多集合，使用Dictionary的编码要简单一些。

我们将确定唯一性Date和TicketNumber作为key的两项组合在一起。

请注意，您需要重命名类模块： cRows ，并且还必须添加对Microsoft Scripting Runtime的引用。

类模块

Option Explicit

'Rename to cRows

Private pDT As Date
Private pTicket As String

Private pCounty As String
Private pCounties As Dictionary

Private pCode As String
Private pCodes As Dictionary

Private pDescription As String
Private pDescriptions As Dictionary

Private pTyp As String
Private pTyps As Dictionary

Private Sub Class_Initialize()
'use dictionaries to combine multiple items
    Set pCounties = New Dictionary
    Set pCodes = New Dictionary
    Set pDescriptions = New Dictionary
    Set pTyps = New Dictionary
End Sub

Public Property Get DT() As Date
    DT = pDT
End Property
Public Property Let DT(Value As Date)
    pDT = Value
End Property

Public Property Get Ticket() As String
    Ticket = pTicket
End Property
Public Property Let Ticket(Value As String)
    pTicket = Value
End Property

Public Property Get County() As String
    County = pCounty
End Property
Public Property Let County(Value As String)
    pCounty = Value
End Property
Public Property Get Counties() As Dictionary
    Set Counties = pCounties
End Property
Public Function ADDCounty(Value As String)
    If Value <> "" Then
        If Not pCounties.Exists(Value) Then _
        pCounties.Add Key:=Value, Item:=Value
    End If
End Function

Public Property Get Code() As String
    Code = pCode
End Property
Public Property Let Code(Value As String)
    pCode = Value
End Property
Public Property Get Codes() As Dictionary
    Set Codes = pCodes
End Property
Public Function ADDCode(Value As String)
    If Value <> "" Then
        If Not pCodes.Exists(Value) Then _
        pCodes.Add Value, Value
    End If
End Function


Public Property Get Description() As String
    Description = pDescription
End Property
Public Property Let Description(Value As String)
    pDescription = Value
End Property
Public Property Get Descriptions() As Dictionary
    Set Descriptions = pDescriptions
End Property
Public Function ADDDescription(Value As String)
    If Value <> "" Then
        If Not pDescriptions.Exists(Value) Then _
        pDescriptions.Add Value, Value
    End If
End Function

Public Property Get Typ() As String
    Typ = pTyp
End Property
Public Property Let Typ(Value As String)
    pTyp = Value
End Property
Public Property Get Typs() As Dictionary
    Set Typs = pTyps
End Property
Public Function ADDTyp(Value As String)
    If Value <> "" Then
        If Not pTyps.Exists(Value) Then _
        pTyps.Add Value, Value
    End If
End Function

Public Function CombineDicts(Dict As Dictionary) As String
    Dim W As Variant, S As String

    For Each W In Dict
        S = S & "," & Dict(W)
    Next W
    CombineDicts = Mid(S, 2)
End Function

常规模块

Option Explicit

'Add Reference (Tools/References) to Microsoft Scripting Runtime

Sub DeDupAndCombine()
    Dim cR As cRows, dR As Dictionary
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim I As Long, J As Long, V As Variant, W As Variant
    Dim sKey As String

Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
    Set rRes = wsRes.Cells(1, 1)

'Get the Source data
With wsSrc
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=6)
End With

'collect and dedup
Set dR = New Dictionary
For I = 2 To UBound(vSrc, 1)
    Set cR = New cRows
    With cR
        .DT = vSrc(I, 2)
        .Ticket = vSrc(I, 5)
        sKey = .DT & "|" & .Ticket

        .County = vSrc(I, 1)
        .ADDCounty .County

        .Code = vSrc(I, 3)
        .ADDCode .Code

        .Description = vSrc(I, 4)
        .ADDDescription .Description

        .Typ = vSrc(I, 6)
        .ADDTyp .Typ

        If Not dR.Exists(sKey) Then
            dR.Add sKey, cR
        Else
            With dR(sKey)
                .ADDCounty cR.County
                .ADDCode cR.Code
                .ADDDescription cR.Description
                .ADDTyp cR.Typ
            End With
        End If
    End With
Next I

'Create the results
ReDim vRes(0 To dR.Count, 1 To 6)

'Headers
For I = 1 To 6
    vRes(0, I) = vSrc(1, I)
Next I

'data
I = 0
For Each V In dR
    I = I + 1
    With dR(V)
        vRes(I, 1) = .CombineDicts(.Counties)
        vRes(I, 2) = .DT
        vRes(I, 3) = .CombineDicts(.Codes)
        vRes(I, 4) = .CombineDicts(.Descriptions)
        vRes(I, 5) = .Ticket
        vRes(I, 6) = .CombineDicts(.Typs)
    End With
Next V

'Write the results
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .EntireColumn.AutoFit
End With

End Sub

如果速度是一个问题，您可以尝试查看执行.RemoveDuplicates方法是否会.RemoveDuplicates执行时间。 您也可以在写入工作表的段之前关闭ScreenUpdating 。