[已解决]使用VBA合并单元格

喜气洋洋

      我是想将 原表 数据的A列相同文本的单元格合并，如 目标表格那样放置
        最后一列，将原A列相同文本的数据对应的原K列（插入A列后变为了L列）的数据相加，如 目标表格那样放置。
       想请坛子里的大师们指点一下，谢谢！

新建 Microsoft Office Excel 工作表.rar (145.59 KB, 下载次数: 26)

2012-11-19 23:24 上传

点击文件名下载附件


目标表

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2012-11-20 11:28

1. Sub 合并()
   
2.     Dim t#
   
3.     t = Timer
   
4.     Application.ScreenUpdating = False
   
5.     Worksheets("原表").Copy after:=Worksheets(Worksheets.Count)
   
6.     Range("a:a").Copy
   
7.     Range("a:a").Insert
   
8.     'Application.CutCopyMode = False
   
9.     Range("a1") = "基站"
   
10.     Range("l:l").Copy
    
11.     Range("l:l").Insert
    
12.     Range("m1") = "基站数"
    
13.     Range("a1").CurrentRegion.Sort key1:=Range("a1"), order1:=xlAscending, Header:=xlYes, SortMethod:=xlPinYin
    
14.     Dim arr
    
15.     Dim iStart&, iEnd&, i&, j&
    
16.     arr = Range("a1").CurrentRegion
    
17.     Application.DisplayAlerts = False
    
18.     j = UBound(arr) - 1
    
19.     For i = 2 To j
    
20.         iStart = i
    
21.         Do While (arr(i, 1) = arr(i + 1, 1))
    
22.             arr(iStart, 13) = arr(iStart, 13) + arr(i + 1, 13)
    
23.             i = i + 1
    
24.             If i > j Then Exit Do
    
25.         Loop
    
26.         If i <> iStart Then
    
27.             Cells(iStart, "m") = arr(iStart, 13)
    
28.             Range("a" & iStart & ":a" & i).Merge
    
29.             Range("m" & iStart & ":m" & i).Merge
    
30.         End If
    
31.     Next
    
32.     MsgBox "合并完成，一共费时" & Timer - t & "秒" & vbCr & "合并后的数据在工作表" & ActiveSheet.Name
    
33.     Application.ScreenUpdating = True
    
34.     Application.DisplayAlerts = True
    
35. End Sub
    

复制代码

新建一个模块，代码复制过去，F5试试。

跳转到最佳答案楼层

hwc2ycy

这个其实都不难的，以前答过类似的题，就是没找到贴子。不然直接贴地址给你了。

喜气洋洋

hwc2ycy 发表于 2012-11-20 08:01
这个其实都不难的，以前答过类似的题，就是没找到贴子。不然直接贴地址给你了。

嗯嗯  谢谢版主
早晨好哦

hwc2ycy

1. Sub 合并()
   
2.     Dim t#
   
3.     t = Timer
   
4.     Application.ScreenUpdating = False
   
5.     Worksheets("原表").Copy after:=Worksheets(Worksheets.Count)
   
6.     Range("a:a").Copy
   
7.     Range("a:a").Insert
   
8.     'Application.CutCopyMode = False
   
9.     Range("a1") = "基站"
   
10.     Range("l:l").Copy
    
11.     Range("l:l").Insert
    
12.     Range("m1") = "基站数"
    
13.     Range("a1").CurrentRegion.Sort key1:=Range("a1"), order1:=xlAscending, Header:=xlYes, SortMethod:=xlPinYin
    
14.     Dim arr
    
15.     Dim iStart&, iEnd&, i&, j&
    
16.     arr = Range("a1").CurrentRegion
    
17.     Application.DisplayAlerts = False
    
18.     j = UBound(arr) - 1
    
19.     For i = 2 To j
    
20.         iStart = i
    
21.         Do While (arr(i, 1) = arr(i + 1, 1))
    
22.             arr(iStart, 13) = arr(iStart, 13) + arr(i + 1, 13)
    
23.             i = i + 1
    
24.             If i > j Then Exit Do
    
25.         Loop
    
26.         If i <> iStart Then
    
27.             Cells(iStart, "m") = arr(iStart, 13)
    
28.             Range("a" & iStart & ":a" & i).Merge
    
29.             Range("m" & iStart & ":m" & i).Merge
    
30.         End If
    
31.     Next
    
32.     MsgBox "合并完成，一共费时" & Timer - t & "秒" & vbCr & "合并后的数据在工作表" & ActiveSheet.Name
    
33.     Application.ScreenUpdating = True
    
34.     Application.DisplayAlerts = True
    
35. End Sub
    

复制代码

新建一个模块，代码复制过去，F5试试。

hwc2ycy

为了避免A列数据没有排序的情况，特意先排了序。
如果楼主在填入数据的时候是按基站名分类输入好的，就可以不用排序这一步。

hwc2ycy

合并(基站).rar (157.21 KB, 下载次数: 15)

2012-11-20 11:33 上传

点击文件名下载附件

hwc2ycy

我才改好，你就给最佳了，楼主，代码测试了没有，

喜气洋洋

hwc2ycy 发表于 2012-11-20 11:33

感谢版主，版主辛苦了，我想问问，我做到了这一步，下一步如何计算最后一列的和。。。


合并.rar (153.86 KB, 下载次数: 1)

2012-11-20 11:35 上传

点击文件名下载附件

喜气洋洋

hwc2ycy 发表于 2012-11-20 11:36
我才改好，你就给最佳了，楼主，代码测试了没有，

我这边运行了下 是自动生成了一个新表的，我自己做的是在原来基础上的
测试了的
没测试 不随便给最佳的哈
我也在写
不能辜负了前辈们的心血啊

喜气洋洋

喜气洋洋 发表于 2012-11-20 11:38
我这边运行了下 是自动生成了一个新表的，我自己做的是在原来基础上的
测试了的
没测试 不随便给最佳的 ...

排序我是用了

Sheets("原表").Range("a2:m" & Range("a1040000").End(xlUp).Row).Sort Range("a1"), xlAscending