[已解决]EXCEl 如何将相同行，转换成单行

Aliya

如有9列，最后一列不一样
ABCDEFGH
……………01
……………02
……………03

转换成
……………01,02,03

将相同行合并，最后一列不同的，加列，往后追加

最佳答案

月排行榜 / 总排行榜

白开水的微笑

2015-4-14 16:35

1. Sub MyMerge()
   
2.     Dim arr
   
3.     Dim d       As Object
   
4.     Dim shtR    As Worksheet
   
5.     Dim shtO    As Worksheet
   
6.     Dim i       As Long
   
7.     Dim rowN    As Long
   
8.     Dim colN    As Long
   
9.     Const Sep   As String = "[_=dp23"
   
10.     Dim sKey    As String
    
11.     Dim lCount  As Long
    
12.     Dim arrTmp
    
13.     Set shtO = ActiveSheet
    
14.     With shtO
    
15.         arr = .Range("A2:H" & Sheet2.Range("A" & .Rows.Count).End(xlUp).Row).Value
    
16.     End With
    
17.     Set d = CreateObject("Scripting.Dictionary")
    
18.     Set shtR = Worksheets.Add
    
19.     shtR.Range("A1:H1").Value = shtO.Range("A1:H1").Value
    
20.     lCount = 1
    
21.     For i = 1 To UBound(arr)
    
22.         sKey = arr(i, 1) & Sep & arr(i, 2) & Sep & arr(i, 3) & Sep & arr(i, 4) & _
    
23.                arr(i, 5) & Sep & arr(i, 6) & Sep & arr(i, 7)
    
24.         If d.exists(sKey) Then
    
25.             arrTmp = Split(d(sKey), Sep)
    
26.             rowN = arrTmp(0)
    
27.             colN = arrTmp(1)
    
28.         Else
    
29.             colN = 8
    
30.             lCount = lCount + 1
    
31.             rowN = lCount
    
32.             Application.Intersect(shtR.Range("A:H"), shtR.Rows(rowN)).Value = _
    
33.                 Application.Intersect(shtO.Range("A:H"), shtO.Rows(i + 1)).Value
    
34.         End If
    
35.         shtR.Cells(rowN, colN).Value = arr(i, 8)
    
36.         d(sKey) = rowN & Sep & colN + 1
    
37.     Next i
    
38. End Sub

复制代码

跳转到最佳答案楼层

Aliya

附件如下

Aliya

求助

白开水的微笑

1. Sub MyMerge()
   
2.     Dim arr
   
3.     Dim d       As Object
   
4.     Dim shtR    As Worksheet
   
5.     Dim shtO    As Worksheet
   
6.     Dim i       As Long
   
7.     Dim rowN    As Long
   
8.     Dim colN    As Long
   
9.     Const Sep   As String = "[_=dp23"
   
10.     Dim sKey    As String
    
11.     Dim lCount  As Long
    
12.     Dim arrTmp
    
13.     Set shtO = ActiveSheet
    
14.     With shtO
    
15.         arr = .Range("A2:H" & Sheet2.Range("A" & .Rows.Count).End(xlUp).Row).Value
    
16.     End With
    
17.     Set d = CreateObject("Scripting.Dictionary")
    
18.     Set shtR = Worksheets.Add
    
19.     shtR.Range("A1:H1").Value = shtO.Range("A1:H1").Value
    
20.     lCount = 1
    
21.     For i = 1 To UBound(arr)
    
22.         sKey = arr(i, 1) & Sep & arr(i, 2) & Sep & arr(i, 3) & Sep & arr(i, 4) & _
    
23.                arr(i, 5) & Sep & arr(i, 6) & Sep & arr(i, 7)
    
24.         If d.exists(sKey) Then
    
25.             arrTmp = Split(d(sKey), Sep)
    
26.             rowN = arrTmp(0)
    
27.             colN = arrTmp(1)
    
28.         Else
    
29.             colN = 8
    
30.             lCount = lCount + 1
    
31.             rowN = lCount
    
32.             Application.Intersect(shtR.Range("A:H"), shtR.Rows(rowN)).Value = _
    
33.                 Application.Intersect(shtO.Range("A:H"), shtO.Rows(i + 1)).Value
    
34.         End If
    
35.         shtR.Cells(rowN, colN).Value = arr(i, 8)
    
36.         d(sKey) = rowN & Sep & colN + 1
    
37.     Next i
    
38. End Sub

复制代码

Aliya

白开水的微笑 发表于 2015-4-14 16:35

Const Sep   As String = "[_=dp23"   解释下这句是什么意思呢 "[_=dp23"

白开水的微笑

Aliya 发表于 2015-4-14 16:42
Const Sep   As String = "[_=dp23"   解释下这句是什么意思呢 "[_=dp23"

没有含义哦，只是添加一个独特的分隔符而已