求助！按单元格批量新增工作表并分类导入数据的相关问题

liuqii

按照书192-194页内容自己做了3个程序。但是结合起来后却运行不起来
我的编程思路
1、按单元格批量新建工作表
2、给每个工作表拷贝表头
3、批量对数据分类拷贝
三个程序单独运行都好用，但是一结合起来就不行了，每一步都写了我的设计思路。请大师们指点一下。
然后如果有更好的思路麻烦展示给我学习一下

1. Sub 按单元格批量新增工作表并分类导入数据()
   
2. 
   
3. Dim a&, b&, sht As Worksheet, c&, i&, d As String, rng As Range, x As String
   
4. a = c = InputBox("请输入第一条记录所在行号")
   
5. b = InputBox("请输入第一条记录所在列号")
   
6. i = a - 1 '确定标题行下限
   
7.     Application.DisplayAlerts = False '关闭屏幕更新
   
8.     Application.ScreenUpdating = False '关闭提示
   
9. Set sht = ActiveSheet
   
10. On Error Resume Next '当没有对应工作表时忽略下一行代码引起的运行时错误
    
11. Do While sht.Cells(a, b).Value <> ""
    
12. If Worksheets(CStr(sht.Cells(a, b).Value)) Is Nothing Then '判断是否存在对应工作表
    
13. Worksheets.Add after:=Worksheets(Worksheets.Count) '在所有工作表后插入新工作表
    
14. ActiveSheet.Name = sht.Cells(a, b).Value '更改表标签名字
    
15.   Set rng = Worksheets(CStr(sht.Cells(a, b).Value)).Rows("1:i") '复制表头到新工作表
    
16. Worksheets(1).Rows("1:i").Copy rng
    
17. End If
    
18. a = a + 1
    
19. Loop
    
20. Sheets(1).Activate '回到第一个工作表
    
21. x = CStr(sht.Cells(c, b).Value) 'x=表名，a之前用过了，现在用c
    
22. Do While x <> ""
    
23. Set rng = Worksheets(x).Range("A65536").End(xlUp).Offset(1, 0) '找到最后一个非空单元格
    
24. Rows(c).Copy rng '整行拷贝
    
25. c = c + 1
    
26. x = CStr(sht.Cells(c, b).Value) '从新定义表名
    
27. Loop
    
28. 
    
29. Application.DisplayAlerts = True  '打开屏幕更新
    
30. Application.ScreenUpdating = True  '打开消息提醒
    
31. 
    
32. End Sub
    
33. 
    

复制代码

运行结果如下不但没拷贝反而多出了几个新表。。（行号2 列号1）

新建 Microsoft Excel 97-2003 工作表 (3).rar (6.92 KB, 下载次数: 131)

2017-4-19 08:21 上传

点击文件名下载附件

ggsmart

引用行那里改成这样试试：
Rows("1:" & i)

liuqii

ggsmart 发表于 2017-4-20 10:41
引用行那里改成这样试试：
Rows("1:" & i)

不行呀，大佬。 是不是逻辑有问题

ggsmart

liuqii 发表于 2017-4-21 09:55
不行呀，大佬。 是不是逻辑有问题

按你的思路改了一下代码：

1. 
   
2. Sub 按单元格批量新增工作表并分类导入数据()
   
3.     Dim a&, b&, sht As Worksheet, c&, i&, d As String, rng As Range, x As String
   
4.     a = InputBox("请输入第一条记录所在行号")
   
5.     c = a
   
6.     b = InputBox("请输入第一条记录所在列号")
   
7.     i = a - 1 '确定标题行
   
8.     Application.DisplayAlerts = False '关闭屏幕更新
   
9.     Application.ScreenUpdating = False '关闭提示
   
10.     Set sht = Worksheets(1)    'ActiveSheet
    
11.     On Error Resume Next '当没有对应工作表时忽略下一行代码引起的运行时错误
    
12.     Do While sht.Cells(a, b).Value <> ""
    
13.         If Worksheets(CStr(sht.Cells(a, b).Value)) Is Nothing Then '判断是否存在对应工作表
    
14.             Worksheets.Add after:=Worksheets(Worksheets.Count) '在所有工作表后插入新工作表
    
15.             ActiveSheet.Name = sht.Cells(a, b).Value '更改表标签名字
    
16.             'Set rng = Worksheets(CStr(sht.Cells(a, b).Value)).Rows("1:i") '复制表头到新工作表
    
17.             sht.Rows("1:" & i).Copy ActiveSheet.Rows(1)
    
18.         End If
    
19.         a = a + 1
    
20.     Loop
    
21.    ' Sheets(1).Activate '回到第一个工作表
    
22.     x = CStr(sht.Cells(c, b).Value) 'x=表名，a之前用过了，现在用c
    
23.     Do While x <> ""
    
24.        Set rng = Worksheets(x).Range("A65536").End(xlUp).Offset(1, 0) '找到最后一个非空单元格
    
25.        sht.Rows(c).Copy rng '整行拷贝
    
26.        c = c + 1
    
27.        x = CStr(sht.Cells(c, b).Value) '从新定义表名
    
28.    Loop
    
29. Application.DisplayAlerts = True  '打开屏幕更新
    
30. Application.ScreenUpdating = True  '打开消息提醒
    
31. End Sub
    

复制代码

另外，整行复制好慢，建议换个思路。

liuqii

ggsmart 发表于 2017-4-21 12:36
按你的思路改了一下代码：

另外，整行复制好慢，建议换个思路。

非常感谢您的帮助，看来逻辑没问题，就是编写细节有问题。以后还要多多努力了。