[已解决]求助改进合并表格程序！

yellowhawk

描述：一个文件中有N个表，我想把每个表格中的内容合并到一个表格中，但每个表格遇到空格就不采集，从第二个表开始采集，同样遇到空格就采集一个表的内容。详情见附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-4-22 13:13

就跟你改了下，其他的没动。

1. Sub 合并()
   
2.     Dim x As Integer
   
3.     Dim y As Integer    '明细表的最后一行
   
4.     Dim z As Integer
   
5.     Dim zz As Integer    '第几行开始复制
   
6.     Application.ScreenUpdating = False
   
7.     Application.DisplayAlerts = False
   
8.     zz = Application.InputBox("不含标题行，从明细表第几行取数", "复制数据", 4)
   
9.     z = zz
   
10. 
    
11.     '复制标题
    
12.     If zz > 1 Then
    
13.         If Sheets(1).Name <> "合并" Then
    
14.             Sheets(1).Rows(1 & ":" & zz - 1).Copy Range("A1")    '
    
15.         Else
    
16.             Sheets(2).Rows(1 & ":" & zz - 1).Copy Range("A1")    '
    
17.         End If
    
18.     End If
    
19. 
    
20.     Range(z & ":65536").Clear
    
21. 
    
22.     For x = 1 To Worksheets.Count
    
23.         If Sheets(x).Name <> "合并" Then
    
24.             z = [b65536].End(xlUp).Row
    
25.             y = Sheets(x).[a1].End(xlDown).Row
    
26.             If y < zz Then GoTo 100    '为空表就不复制
    
27.             Sheets(x).Rows(zz & ":" & y).Copy Range("A" & z + 1)    'zz明细表第几行取数
    
28. 100:
    
29.         End If
    
30.     Next x
    
31. 
    
32.     '加明细表名称
    
33.     Dim ss As Integer
    
34. 
    
35. 
    
36.     ss = Cells(zz - 1, 256).End(xlToLeft).Column + 1    '增加一列，显示明细表名称
    
37.     Cells(zz - 1, ss) = "明细表"
    
38.     For x = 1 To Worksheets.Count
    
39.         If Sheets(x).Name <> "合并" Then
    
40.             z = Cells(65536, ss).End(xlUp).Row
    
41.             y = Sheets(x).[a1].End(xlDown).Row
    
42.             If y < zz Then GoTo 200    '为空表就不复制
    
43.             Range(Cells(z + 1, ss), Cells(z + 1 + y - zz, ss)) = Sheets(x).Name    '加明细表名称
    
44. 200:
    
45.         End If
    
46.     Next x
    
47. 
    
48.     With Sheets("合并")
    
49.         ROW1 = .Range("B65536").End(xlUp).Row
    
50.         For K = ROW1 To zz + 1 Step -1
    
51.             If .Cells(K, 2) = "" Then Cells(K, 2).EntireRow.Delete
    
52.         Next K
    
53. 
    
54.         .Cells(1, 2).Select
    
55. 
    
56.     End With
    
57.     MsgBox "合并成功！！", , "提示您"
    
58. 
    
59.     Application.ScreenUpdating = True
    
60.     Application.DisplayAlerts = True
    
61. End Sub

复制代码

跳转到最佳答案楼层

zjdh

有表2那样的情况，出现空格后，下面又有数据吗？

hwc2ycy

就跟你改了下，其他的没动。

1. Sub 合并()
   
2.     Dim x As Integer
   
3.     Dim y As Integer    '明细表的最后一行
   
4.     Dim z As Integer
   
5.     Dim zz As Integer    '第几行开始复制
   
6.     Application.ScreenUpdating = False
   
7.     Application.DisplayAlerts = False
   
8.     zz = Application.InputBox("不含标题行，从明细表第几行取数", "复制数据", 4)
   
9.     z = zz
   
10. 
    
11.     '复制标题
    
12.     If zz > 1 Then
    
13.         If Sheets(1).Name <> "合并" Then
    
14.             Sheets(1).Rows(1 & ":" & zz - 1).Copy Range("A1")    '
    
15.         Else
    
16.             Sheets(2).Rows(1 & ":" & zz - 1).Copy Range("A1")    '
    
17.         End If
    
18.     End If
    
19. 
    
20.     Range(z & ":65536").Clear
    
21. 
    
22.     For x = 1 To Worksheets.Count
    
23.         If Sheets(x).Name <> "合并" Then
    
24.             z = [b65536].End(xlUp).Row
    
25.             y = Sheets(x).[a1].End(xlDown).Row
    
26.             If y < zz Then GoTo 100    '为空表就不复制
    
27.             Sheets(x).Rows(zz & ":" & y).Copy Range("A" & z + 1)    'zz明细表第几行取数
    
28. 100:
    
29.         End If
    
30.     Next x
    
31. 
    
32.     '加明细表名称
    
33.     Dim ss As Integer
    
34. 
    
35. 
    
36.     ss = Cells(zz - 1, 256).End(xlToLeft).Column + 1    '增加一列，显示明细表名称
    
37.     Cells(zz - 1, ss) = "明细表"
    
38.     For x = 1 To Worksheets.Count
    
39.         If Sheets(x).Name <> "合并" Then
    
40.             z = Cells(65536, ss).End(xlUp).Row
    
41.             y = Sheets(x).[a1].End(xlDown).Row
    
42.             If y < zz Then GoTo 200    '为空表就不复制
    
43.             Range(Cells(z + 1, ss), Cells(z + 1 + y - zz, ss)) = Sheets(x).Name    '加明细表名称
    
44. 200:
    
45.         End If
    
46.     Next x
    
47. 
    
48.     With Sheets("合并")
    
49.         ROW1 = .Range("B65536").End(xlUp).Row
    
50.         For K = ROW1 To zz + 1 Step -1
    
51.             If .Cells(K, 2) = "" Then Cells(K, 2).EntireRow.Delete
    
52.         Next K
    
53. 
    
54.         .Cells(1, 2).Select
    
55. 
    
56.     End With
    
57.     MsgBox "合并成功！！", , "提示您"
    
58. 
    
59.     Application.ScreenUpdating = True
    
60.     Application.DisplayAlerts = True
    
61. End Sub

复制代码

yellowhawk

我对照了原代码，怎么看不出你改在哪里了