数据批量整理怎么弄啊？

寿司的骆驼

各位老师请见附件，内容有合并单元格，如果数据整理到一起？

3190496160

这个得用代码来才行吧

3190496160

Sub 整理数据()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheet1
   r = .Cells(Rows.Count, 6).End(xlUp).Row
    If r < 2 Then MsgBox "数据源为空！": End
    ar = .Range("a1:i" & r)
End With
Dim br()
ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
For i = 2 To UBound(ar)
    If Trim(ar(i, 1)) = "" Then
        For j = 1 To 5
            ar(i, j) = ar(i - 1, j)
        Next j
    End If
    zf = ar(i, 1) & "|" & ar(i, 2)
   d(zf) = ""
Next i
For Each k In d.keys
    n = n + 1
    For i = 2 To UBound(ar)
        zf = ar(i, 1) & "|" & ar(i, 2)
        If zf = k Then
            For j = 1 To UBound(ar, 2)
                If j <> 6 And j <> 7 Then
                    br(n, j) = ar(i, j)
                End If
            Next j
            If br(n, 6) = "" Then
                br(n, 6) = ar(i, 6) & ar(i, 7) & ar(i, 8)
            Else
                br(n, 6) = br(n, 6) & "," & ar(i, 6) & ar(i, 7) & ar(i, 8)
            End If
            br(n, 7) = br(n, 7) + ar(i, 7)
        End If
    Next i
Next k
With Sheets("整理")
    .[a1].CurrentRegion.Offset(1) = Empty
    .[a2].Resize(n, UBound(br, 2)) = br
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

求助.rar (20.12 KB, 下载次数: 11)

2023-8-21 11:36 上传

点击文件名下载附件

一剑惊心

PQ也可以整理出来

寿司的骆驼

3190496160 发表于 2023-8-21 11:36

谢谢老师，很有用，感谢！