[已解决]求助，批量合并【相似！】行

youxianwei · 发表于 2016-10-30 14:47

求助，批量合并【相似！】行

最佳答案

爱疯

2016-11-1 11:28

Sub test()
Dim A, B, d, i%, j%, s, x

Sheets(1).Select
A = Range("a1:k" & Range("a65536").End(xlUp).Row)
ReDim B(1 To UBound(A), 1 To UBound(A, 2))
Set d = CreateObject("scripting.dictionary")

For i = 1 To UBound(A)
      x = A(i, 5) 'key
      If x <> "" Then
         If d.exists(x) Then
            '已存在
            For j = 1 To UBound(A, 2)
                  If B(d(x), j) = "" Then B(d(x), j) = A(i, j)
            Next j
         Else
            '不存在
            s = s + 1: d(x) = s
            For j = 1 To UBound(A, 2)
                  B(s, j) = A(i, j)
            Next j
         End If
      End If
Next i

Cells.Delete
If s Then [a1].Resize(s, UBound(B, 2)) = B
End Sub

这样可以吗

跳转到最佳答案楼层

爱疯 · 发表于 2016-11-1 09:51

Sub test()
Dim A, B, d, i%, j%, s, x

Sheets(1).Select
A = Range("a1:k" & Range("a65536").End(xlUp).Row)
ReDim B(1 To UBound(A), 1 To UBound(A, 2))
Set d = CreateObject("scripting.dictionary")

For i = 2 To UBound(A)
      x = A(i, 5) 'key
      If x <> "" Then
         If d.exists(x) Then
            '已存在
            For j = 1 To UBound(A, 2)
                  If B(d(x), j) = "" Then B(d(x), j) = A(i, j)
            Next j
         Else
            '不存在
            s = s + 1: d(x) = s
            For j = 1 To UBound(A, 2)
                  B(s, j) = A(i, j)
            Next j
         End If
      End If
Next i

Sheets(2).Select '事先手动创建了第2个工作表，用于存放结果
Range("e:e").NumberFormat = "@"
Range("a1").CurrentRegion.ClearContents
If s Then [a1].Resize(s, UBound(B, 2)) = B
Sheets(2).UsedRange.EntireColumn.AutoFit
End Sub

合并2.rar (30.04 KB, 下载次数: 14)

youxianwei · 发表于 2016-11-1 10:47

非常感谢！，能否原表格自动清除重重新排列？

还有我装了2016后 Range("e:e").NumberFormat = "@"有bug，是不是2016的问题？

爱疯 · 发表于 2016-11-1 11:28

Sub test()
Dim A, B, d, i%, j%, s, x

Sheets(1).Select
A = Range("a1:k" & Range("a65536").End(xlUp).Row)
ReDim B(1 To UBound(A), 1 To UBound(A, 2))
Set d = CreateObject("scripting.dictionary")

For i = 1 To UBound(A)
      x = A(i, 5) 'key
      If x <> "" Then
         If d.exists(x) Then
            '已存在
            For j = 1 To UBound(A, 2)
                  If B(d(x), j) = "" Then B(d(x), j) = A(i, j)
            Next j
         Else
            '不存在
            s = s + 1: d(x) = s
            For j = 1 To UBound(A, 2)
                  B(s, j) = A(i, j)
            Next j
         End If
      End If
Next i

Cells.Delete
If s Then [a1].Resize(s, UBound(B, 2)) = B
End Sub

这样可以吗

youxianwei · 发表于 2016-11-1 12:01

爱疯发表于 2016-11-1 11:28
Sub test()
Dim A, B, d, i%, j%, s, x

大神您太厉害了，回答神速。。。

youxianwei · 发表于 2016-11-1 12:05

本帖最后由 youxianwei 于 2016-11-1 12:20 编辑

不过每列重复的内容只会保留重复行中的第一行而删除其他行内容，有时候真说不清该不该删，请问将重复内容逗号合并到最终结果中的代码又该怎样写呢？

还有e列的公式被清除了，能否保留原公式关系？？

爱疯 · 发表于 2016-11-1 16:26

Sub test()
Dim A, B, d, i%, j%, s, x, gs
Sheets(1).Select
gs = Range("e1").Formula
A = Range("a1:k" & Range("a65536").End(xlUp).Row)
ReDim B(1 To UBound(A), 1 To UBound(A, 2))
Set d = CreateObject("scripting.dictionary")

For i = 2 To UBound(A)
      x = A(i, 5) 'key
      If x <> "" Then
         If d.exists(x) Then
            '已存在
            For j = 1 To UBound(A, 2)
                  If B(d(x), j) = "" Then B(d(x), j) = A(i, j)
            Next j
         Else
            '不存在
            s = s + 1: d(x) = s
            For j = 1 To UBound(A, 2)
                  B(s, j) = A(i, j)
            Next j
         End If
      End If
Next i

Sheets(2).Select '结果存放到指定工作表
Cells.Clear
[a1].Resize(s, UBound(B, 2)) = B
Range("e1") = gs
Range("e1").Resize(Range("e65536").End(xlUp).Row).FillDown
End Sub

合并3.rar (28.59 KB, 下载次数: 13)

youxianwei · 发表于 2016-11-1 16:35

太感谢了，真完美！

youxianwei · 发表于 2016-11-1 16:37

本帖最后由 youxianwei 于 2016-11-1 16:47 编辑

当然能本表清理最好不过了，本表上方保留几行标题行，总是不希望出现第二个辅助表，或者辅助列之类的情况，总是想鱼和熊掌兼得。

youxianwei · 发表于 2016-11-1 19:46

爱疯发表于 2016-11-1 16:26
Sub test()
Dim A, B, d, i%, j%, s, x, gs
Sheets(1).Select

大神，如果要开头三行座位标题不被数组更新掉该怎么写代码呀？

		自动登录	找回密码
密码			注册

[已解决]求助，批量合并【相似！】行

评分

评分