[已解决]求助：合并工作薄中各工作表同单元格内容

斗笠渔翁

再次请老师们帮忙：合并工作薄中各工作表同单元格内容，VBA实现，详见附件 合并工作薄中各工作表同单元格内容.zip (5.22 KB, 下载次数: 28)

2012-11-8 13:28 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2012-11-8 13:57

1. Sub 合并内容()
   
2.     Dim shtS
   
3.     Dim colh$, colj$
   
4.     Dim i&
   
5.     Application.ScreenUpdating = False
   
6.     Union(Range("h3:h6"), Range("j3:j6")).ClearContents
   
7.     For Each shtS In Worksheets
   
8.         If shtS.Name Like "表*" Then
   
9.             For i = 3 To 6
   
10.                 colh = Cells(i, "h")
    
11.                 colj = Cells(i, "j")
    
12.                 If Len(colh) Then colh = colh & Chr(10)
    
13.                 If Len(colj) Then colj = colj & Chr(10)
    
14.                 Cells(i, "h") = colh & shtS.Cells(i, "h")
    
15.                 Cells(i, "j") = colj & shtS.Cells(i, "j")
    
16.             Next
    
17.         End If
    
18.     Next
    
19.     Union(Range("h3:h6"), Range("j3:j6")).EntireColumn.AutoFit
    
20.     Application.ScreenUpdating = True
    
21. End Sub
    

复制代码

多加了2句判断，空白行没有了。
刚没加防刷屏的，现在补上了。

跳转到最佳答案楼层

hwc2ycy

1. Sub 合并内容()
   
2.     Dim shtS
   
3.     Dim colh$, colj$
   
4.     Dim i&
   
5.    Application.ScreenUpdating = False
   
6.     Union(Range("h3:h6"), Range("j3:j6")).ClearContents
   
7.    
   
8.     For Each shtS In Worksheets
   
9.         If shtS.Name Like "表*" Then
   
10.             For i = 3 To 6
    
11.                 colh = Cells(i, "h")
    
12.                 colj = Cells(i, "j")
    
13.                 Cells(i, "h") = colh & shtS.Cells(i, "h") & Chr(10)
    
14.                 Cells(i, "j") = colj & shtS.Cells(i, "j") & Chr(10)
    
15.             Next
    
16.         End If
    
17.     Next
    
18.     Union(Range("h3:h6"), Range("j3:j6")).EntireColumn.AutoFit
    
19.     Application.ScreenUpdating = true
    
20. End Sub

复制代码

放在汇总工作表模块里，美中不足的是最后多了一行。

hwc2ycy

1. Sub 合并内容()
   
2.     Dim shtS
   
3.     Dim colh$, colj$
   
4.     Dim i&
   
5.     Application.ScreenUpdating = False
   
6.     Union(Range("h3:h6"), Range("j3:j6")).ClearContents
   
7.     For Each shtS In Worksheets
   
8.         If shtS.Name Like "表*" Then
   
9.             For i = 3 To 6
   
10.                 colh = Cells(i, "h")
    
11.                 colj = Cells(i, "j")
    
12.                 If Len(colh) Then colh = colh & Chr(10)
    
13.                 If Len(colj) Then colj = colj & Chr(10)
    
14.                 Cells(i, "h") = colh & shtS.Cells(i, "h")
    
15.                 Cells(i, "j") = colj & shtS.Cells(i, "j")
    
16.             Next
    
17.         End If
    
18.     Next
    
19.     Union(Range("h3:h6"), Range("j3:j6")).EntireColumn.AutoFit
    
20.     Application.ScreenUpdating = True
    
21. End Sub
    

复制代码

多加了2句判断，空白行没有了。
刚没加防刷屏的，现在补上了。

斗笠渔翁

hwc2ycy 发表于 2012-11-8 13:57
多加了2句判断，空白行没有了。
刚没加防刷屏的，现在补上了。

太谢谢了！我每月这样的汇总N次！

hwc2ycy

呵呵，写的这点小小小小代码能帮助大家解决实际中的问题，