将同一序号的多行名称进行单元格合并

APPLE123

使用vba将Sheet1  B列会计师事务所名称中包含原名称的，进行单元格合并，如序号：31、66、84、85、95......合并后形如Sheet2，请老师帮帮忙，谢谢！

ykcbf1100

附件供参考。。。

ykcbf1100

1. Sub ykcbf()   '//2025.11.3
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     arr = Sheets("Sheet1").UsedRange.Value
   
5.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
6.     For i = 3 To UBound(arr)
   
7.         For j = 1 To UBound(arr, 2)
   
8.             If j <> 2 Then
   
9.                 If arr(i, j) = Empty Then arr(i, j) = arr(i - 1, j)
   
10.             End If
    
11.         Next
    
12.         If Len(arr(i, 1) & "") Then
    
13.             s = arr(i, 1)
    
14.             If Not d.exists(s) Then
    
15.                 m = m + 1
    
16.                 d(s) = m
    
17.                 For j = 1 To UBound(arr, 2)
    
18.                     brr(m, j) = arr(i, j)
    
19.                 Next
    
20.             Else
    
21.                 r = d(s)
    
22.                 If arr(i, 2) <> Empty Then
    
23.                     brr(r, 2) = brr(r, 2) & Chr(10) & arr(i, 2)
    
24.                 End If
    
25.             End If
    
26.         End If
    
27.     Next
    
28.     With Sheets("Sheet2")
    
29.         .UsedRange.Offset(2).ClearContents
    
30.         .[a3].Resize(m, 5) = brr
    
31.         .[a3].Resize(m, 5).Borders.LineStyle = 1
    
32.     End With
    
33.     Application.ScreenUpdating = True
    
34.     MsgBox "OK！"
    
35. End Sub
    

复制代码

cpa_cpv

PQ 轻松搞定。还能自动更新。。。。。。。。。

gwjkkkkk

Option Explicit
Sub test1()
    Dim ar, i&, j&, r&, isFlag As Boolean
   
    With Worksheets(1)
        With .Range("A1").CurrentRegion
            ar = Intersect(.Offset(), .Offset(1)).Value
        End With
        For i = 1 To UBound(ar)
            If Len(ar(i, 1)) Then
                r = r + 1
                For j = 1 To UBound(ar, 2)
                    ar(r, j) = ar(i, j)
                Next j
            Else
                If Len(ar(i, 2)) Then
                    ar(r, 2) = ar(r, 2) & vbCrLf & ar(i, 2)
                End If
            End If
        Next i
    End With
   
    With Worksheets(2)
        .Range("A1").CurrentRegion.Offset(1).Clear
        With .Range("A2").Resize(r, UBound(ar, 2))
            .Value = ar
            .HorizontalAlignment = xlCenter
            .Borders.LineStyle = xlContinuous
            .Borders.Weight = xlMedium
            .Columns(3).NumberFormatLocal = "yyyy/m/d"
            .EntireColumn.AutoFit
        End With
        .Activate
    End With
    Beep
End Sub

gwjkkkkk

半百

APPLE123

感谢各位老师的帮助！谢谢！