[已解决]顶端标题行与内容合并，相同日期的内容合并

yangset3220

顶端标题行与内容合并，相同日期的内容合并.rar (4.28 KB, 下载次数: 14)

2013-3-9 14:43 上传

点击文件名下载附件 顶端标题行与内容合并，相同日期的内容合并，如题

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-3-10 20:50

顶端标题行与内容合并，相同日期的内容合并.rar (11.49 KB, 下载次数: 20)

2013-3-10 20:50 上传

点击文件名下载附件
数据量达到上万行时，这个代码就会影响效率了。

跳转到最佳答案楼层

hwc2ycy

1. Sub 合并表格()
   
2.     Dim lLastrow As Long
   
3.     Dim i As Long, j As Long
   
4.     Dim arr
   
5.     Dim arrResult()
   
6.     Dim strMerge As String
   
7.    
   
8.     lLastrow = Cells(Rows.Count, 2).End(xlUp).Row
   
9.     arr = Range("b2:f" & lLastrow)
   
10.     ReDim arrResult(1 To UBound(arr), 1 To 2)
    
11.     arrResult(1, 1) = "日期"
    
12.     arrResult(1, 2) = "事项"
    
13.    
    
14.     Application.ScreenUpdating = False
    
15.     For i = 2 To UBound(arr)
    
16.         
    
17.         strMerge = ""
    
18.         For j = LBound(arr) + 1 To UBound(arr, 2)
    
19.             If Len(arr(i, j)) > 0 Then
    
20.                 strMerge = strMerge & arr(1, j) & ":" & arr(i, j) & "；"
    
21.             End If
    
22.         Next
    
23.         If Len(strMerge) > 0 Then
    
24.         
    
25.         arrResult(i, 1) = arr(i, 1)
    
26.         strMerge = Left(strMerge, Len(strMerge) - 1) & "。"
    
27.         arrResult(i, 2) = strMerge
    
28.         End If
    
29.     Next
    
30.    
    
31.     Columns("h:j") = ""
    
32.     Range("h2").Resize(i - 1, j - 1) = arrResult
    
33.     Application.ScreenUpdating = True
    
34.     MsgBox "合并完成"
    
35. End Sub
    

复制代码

hwc2ycy

1. Sub 合并表格()
   
2.     Dim lLastrow As Long
   
3.     Dim i As Long, j As Long
   
4.     Dim arr
   
5.     Dim arrResult()
   
6.     Dim strMerge As String
   
7.    
   
8.     lLastrow = Cells(Rows.Count, 2).End(xlUp).Row
   
9.     arr = Range("b2:f" & lLastrow)
   
10.     ReDim arrResult(1 To UBound(arr), 1 To 2)
    
11.     arrResult(1, 1) = "日期"
    
12.     arrResult(1, 2) = "事项"
    
13.    
    
14.     Application.ScreenUpdating = False
    
15.     For i = 2 To UBound(arr)
    
16.         
    
17.         strMerge = ""
    
18.         For j = LBound(arr) + 1 To UBound(arr, 2)
    
19.             If Len(arr(i, j)) > 0 Then
    
20.                 strMerge = strMerge & arr(1, j) & ":" & arr(i, j) & "；"
    
21.             End If
    
22.         Next
    
23.         If Len(strMerge) > 0 Then
    
24.         
    
25.         arrResult(i, 1) = arr(i, 1)
    
26.         strMerge = Left(strMerge, Len(strMerge) - 1) & "。"
    
27.         arrResult(i, 2) = strMerge
    
28.         End If
    
29.     Next
    
30.    
    
31.     Columns("h:j") = ""
    
32.     Range("h2").Resize(i - 1, j - 1) = arrResult
    
33.     Application.ScreenUpdating = True
    
34.     MsgBox "合并完成"
    
35. End Sub
    

复制代码

yangset3220

谢谢大师们，我正在试用呢

yangset3220

试过后，就是相同的日期的内容无法合并在一起

yangset3220

另外这个VBA能否改成那种单元格改变时，自动执行的

hwc2ycy

你把你放了代码的附件放上来吧，我这测了是可以的。

yangset3220

已将代码做进去了，最好将VBA代码优化成单元格改变时自动执行

hwc2ycy

顶端标题行与内容合并，相同日期的内容合并.rar (11.49 KB, 下载次数: 20)

2013-3-10 20:50 上传

点击文件名下载附件
数据量达到上万行时，这个代码就会影响效率了。

yangset3220

谢谢hwc2ycy 大师的倾力相助，非常感谢！！！！！！！！！！！！！！！！