条件合并，请帮忙看看，多谢。

2728911088

根据订单号相同的，全部合并成1行。

数据源：

结果区：

剑指E

1. Private Sub CommandButton1_Click()
   
2.     Application.ScreenUpdating = False
   
3.     Dim r&, h&, n&, i&, j As Byte, ar(1 To 99999, 1 To 8)
   
4.     h = Cells(Rows.Count, 1).End(xlUp).Row
   
5.     For i = 2 To h
   
6.         If Cells(i, 8) <> Cells(i - 1, 8) Then r = i
   
7.         If Cells(i, 8) <> Cells(i + 1, 8) Then
   
8.             n = n + 1
   
9.             ar(n, 1) = n
   
10.             For j = 2 To 7
    
11.                 ar(n, j) = Join(Application.Transpose(Range(Cells(r, j), Cells(i, j)).Value), vbLf)
    
12.             Next
    
13.             ar(n, 8) = Cells(r, 8)
    
14.         End If
    
15.     Next
    
16.     Cells(2, 1).Resize(h, 8).ClearContents
    
17.     Cells(2, 1).Resize(n, 8) = ar
    
18.     Application.ScreenUpdating = True
    
19. End Sub

复制代码

剑指E

.                                        .                        

ykcbf1100

这其实就是一个合并单元格的问题。

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, i&, j&, r&, dic As Object, strKey$, iPosRow&
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = [A1].CurrentRegion: r = 1
    For i = 2 To UBound(ar)
        strKey = ar(i, UBound(ar, 2))
        If Not dic.exists(strKey) Then
            r = r + 1
            For j = 2 To UBound(ar, 2)
                ar(r, j) = ar(i, j)
            Next j
            ar(r, 1) = r - 1
            dic(strKey) = r
        Else
            iPosRow = dic(strKey)
            For j = 2 To UBound(ar, 2) - 1
                ar(iPosRow, j) = ar(iPosRow, j) & vbLf & ar(i, j)
            Next j
        End If
    Next i
   
    With Sheets(2)
        .Cells.Clear
        .[A1].Resize(r, UBound(ar, 2)) = ar
        .Activate
    End With
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。