[已解决]VBA实现将一表的数据导入另一张表

KDZ

     各们大师：请教如何用VBA实现将登记表的数据导入另一张汇总表内，具体要求请祥见汇总表。因有数千条数据，所以不用函数。先行谢谢！

最佳答案

月排行榜 / 总排行榜

13052565705

2017-2-6 16:37

1. Option Explicit
   
2. Sub 数据转移()
   
3.     Dim arr, result1, result2, result3, result4
   
4.     Dim k As Long
   
5.     Dim x As Long
   
6.     Dim i As Long
   
7.     Dim cnt As Long
   
8.     Dim temp As String
   
9.     Dim wb As Workbook
   
10.     Application.ScreenUpdating = False
    
11.     Set wb = Workbooks.Open("C:\Users\lsf800\Desktop" & "登记表")
    
12.     k = Cells(Rows.Count, 3).End(xlUp).Row
    
13.     arr = wb.Sheets("sheet1").Range("b3:d" & k).Value
    
14.     wb.Close 0
    
15.     ReDim result1(1 To UBound(arr), 1 To 1)
    
16.     ReDim result2(1 To UBound(arr), 1 To 1)
    
17.     ReDim result3(1 To UBound(arr), 1 To 1)
    
18.     ReDim result4(1 To UBound(arr), 1 To 1)
    
19.     For x = 2 To UBound(arr)
    
20.         If arr(x, 2) <> "" Then
    
21.             cnt = cnt + 1
    
22.             If arr(x, 1) <> "" Then
    
23.                 result1(cnt, 1) = arr(x, 1)
    
24.                 temp = arr(x, 3)
    
25.             Else:
    
26.                 result1(cnt, 1) = result1(cnt - 1, 1)
    
27.             End If
    
28.             result2(cnt, 1) = "'" & temp
    
29.             result3(cnt, 1) = arr(x, 2)
    
30.             result4(cnt, 1) = "'" & arr(x, 3)
    
31.         End If
    
32.     Next x
    
33.     Workbooks("汇总表").Sheets("sheet1").Range("i2").Resize(UBound(arr), 1) = result1
    
34.     Workbooks("汇总表").Sheets("sheet1").Range("k2").Resize(UBound(arr), 1) = result2
    
35.     Workbooks("汇总表").Sheets("sheet1").Range("m2").Resize(UBound(arr), 1) = result3
    
36.     Workbooks("汇总表").Sheets("sheet1").Range("u2").Resize(UBound(arr), 1) = result4
    
37.     Application.ScreenUpdating = True
    
38. End Sub
    
39. 
    

复制代码

这是删除空白行后的代码。
代码运行出现错误，中间有一段是调用登记表的路径，就是Set wb = Workbooks.Open("C:\Users\lsf800\Desktop\" & "登记表")这一段，文件保存的路径你要自己手动改一下的，亲~

跳转到最佳答案楼层

13052565705

1. Option Explicit
   
2. Sub 数据转移()
   
3.     Dim arr, result1, result2, result3, result4
   
4.     Dim k As Long
   
5.     Dim x As Long
   
6.     Dim i As Long
   
7.     Dim temp As String
   
8.     Dim wb As Workbook
   
9.     Application.ScreenUpdating = False
   
10.     Set wb = Workbooks.Open("C:\Users\lsf800\Desktop" & "登记表")
    
11.     k = Cells(Rows.Count, 3).End(xlUp).Row
    
12.     arr = wb.Sheets("sheet1").Range("b3:d" & k).Value
    
13.     wb.Close 0
    
14.     ReDim result1(1 To UBound(arr), 1 To 1)
    
15.     ReDim result2(1 To UBound(arr), 1 To 1)
    
16.     ReDim result3(1 To UBound(arr), 1 To 1)
    
17.     ReDim result4(1 To UBound(arr), 1 To 1)
    
18.     For x = 2 To UBound(arr)
    
19.         If arr(x, 1) <> "" Then
    
20.             result1(x - 1, 1) = arr(x, 1)
    
21.             temp = arr(x, 3)
    
22.         Else:
    
23.             result1(x - 1, 1) = result1(x - 2, 1)
    
24.         End If
    
25.         result2(x - 1, 1) = "'" & temp
    
26.         result3(x - 1, 1) = arr(x, 2)
    
27.         result4(x - 1, 1) = "'" & arr(x, 3)
    
28.     Next x
    
29.     Workbooks("汇总表").Sheets("sheet1").Range("i2").Resize(UBound(arr), 1) = result1
    
30.     Workbooks("汇总表").Sheets("sheet1").Range("k2").Resize(UBound(arr), 1) = result2
    
31.     Workbooks("汇总表").Sheets("sheet1").Range("m2").Resize(UBound(arr), 1) = result3
    
32.     Workbooks("汇总表").Sheets("sheet1").Range("u2").Resize(UBound(arr), 1) = result4
    
33.     Application.ScreenUpdating = True
    
34. End Sub
    

复制代码

看看合适吗？合适的话给个最佳吧亲~

13052565705

有一个小问题，登记表的最后一行有合并单元格的家主，但是没有家庭成员的信息，不知道这一行是否要保留。
我上面给你的是把这行保留了，有家主和家主的身份证号，没有家庭成员的姓名和身份证号码。
如果有删除的需求，我再完善一下

KDZ

13052565705 发表于 2017-2-6 15:44
有一个小问题，登记表的最后一行有合并单元格的家主，但是没有家庭成员的信息，不知道这一行是否要保留。
...

谢谢大师，谢谢大师，一定一定，一有删除的要求，二另外怎么复制了代码后，运行错误400，还请大师解决下，谢谢！！！

13052565705

1. Option Explicit
   
2. Sub 数据转移()
   
3.     Dim arr, result1, result2, result3, result4
   
4.     Dim k As Long
   
5.     Dim x As Long
   
6.     Dim i As Long
   
7.     Dim cnt As Long
   
8.     Dim temp As String
   
9.     Dim wb As Workbook
   
10.     Application.ScreenUpdating = False
    
11.     Set wb = Workbooks.Open("C:\Users\lsf800\Desktop" & "登记表")
    
12.     k = Cells(Rows.Count, 3).End(xlUp).Row
    
13.     arr = wb.Sheets("sheet1").Range("b3:d" & k).Value
    
14.     wb.Close 0
    
15.     ReDim result1(1 To UBound(arr), 1 To 1)
    
16.     ReDim result2(1 To UBound(arr), 1 To 1)
    
17.     ReDim result3(1 To UBound(arr), 1 To 1)
    
18.     ReDim result4(1 To UBound(arr), 1 To 1)
    
19.     For x = 2 To UBound(arr)
    
20.         If arr(x, 2) <> "" Then
    
21.             cnt = cnt + 1
    
22.             If arr(x, 1) <> "" Then
    
23.                 result1(cnt, 1) = arr(x, 1)
    
24.                 temp = arr(x, 3)
    
25.             Else:
    
26.                 result1(cnt, 1) = result1(cnt - 1, 1)
    
27.             End If
    
28.             result2(cnt, 1) = "'" & temp
    
29.             result3(cnt, 1) = arr(x, 2)
    
30.             result4(cnt, 1) = "'" & arr(x, 3)
    
31.         End If
    
32.     Next x
    
33.     Workbooks("汇总表").Sheets("sheet1").Range("i2").Resize(UBound(arr), 1) = result1
    
34.     Workbooks("汇总表").Sheets("sheet1").Range("k2").Resize(UBound(arr), 1) = result2
    
35.     Workbooks("汇总表").Sheets("sheet1").Range("m2").Resize(UBound(arr), 1) = result3
    
36.     Workbooks("汇总表").Sheets("sheet1").Range("u2").Resize(UBound(arr), 1) = result4
    
37.     Application.ScreenUpdating = True
    
38. End Sub
    
39. 
    

复制代码

这是删除空白行后的代码。
代码运行出现错误，中间有一段是调用登记表的路径，就是Set wb = Workbooks.Open("C:\Users\lsf800\Desktop\" & "登记表")这一段，文件保存的路径你要自己手动改一下的，亲~

KDZ

13052565705 发表于 2017-2-6 16:37
这是删除空白行后的代码。
代码运行出现错误，中间有一段是调用登记表的路径，就是Set wb = Workbooks.O ...

谢谢大师，真乃高手啊，不过我是菜鸟不会手动修改保存路径，哈哈哈哈，麻烦大师将附有代码的登记表、汇总表放在一个文件夹内【我的这两个表保存路径都是在桌面上】我可以直接能套用的就行了。害羞害羞，帮人帮到底，跪谢！！！！

13052565705

1. Option Explicit
   
2. Sub 数据转移()
   
3.     Dim arr, result1, result2, result3, result4
   
4.     Dim k As Long
   
5.     Dim x As Long
   
6.     Dim i As Long
   
7.     Dim cnt As Long
   
8.     Dim temp As String
   
9.     Dim wb As Workbook
   
10.     Application.ScreenUpdating = False
    
11.     Set wb = Workbooks.Open(ThisWorkbook.Path & "\登记表")
    
12.     k = Cells(Rows.Count, 3).End(xlUp).Row
    
13.     arr = wb.Sheets("登记表").Range("b3:d" & k).Value
    
14.     wb.Close 0
    
15.     ReDim result1(1 To UBound(arr), 1 To 1)
    
16.     ReDim result2(1 To UBound(arr), 1 To 1)
    
17.     ReDim result3(1 To UBound(arr), 1 To 1)
    
18.     ReDim result4(1 To UBound(arr), 1 To 1)
    
19.     For x = 2 To UBound(arr)
    
20.         If arr(x, 2) <> "" Then
    
21.             cnt = cnt + 1
    
22.             If arr(x, 1) <> "" Then
    
23.                 result1(cnt, 1) = arr(x, 1)
    
24.                 temp = arr(x, 3)
    
25.             Else:
    
26.                 result1(cnt, 1) = result1(cnt - 1, 1)
    
27.             End If
    
28.             result2(cnt, 1) = "'" & temp
    
29.             result3(cnt, 1) = arr(x, 2)
    
30.             result4(cnt, 1) = "'" & arr(x, 3)
    
31.         End If
    
32.     Next x
    
33.     Workbooks("汇总表").Sheets("sheet1").Range("i2").Resize(UBound(arr), 1) = result1
    
34.     Workbooks("汇总表").Sheets("sheet1").Range("k2").Resize(UBound(arr), 1) = result2
    
35.     Workbooks("汇总表").Sheets("sheet1").Range("m2").Resize(UBound(arr), 1) = result3
    
36.     Workbooks("汇总表").Sheets("sheet1").Range("u2").Resize(UBound(arr), 1) = result4
    
37.     Application.ScreenUpdating = True
    
38. End Sub
    
39. 
    

复制代码

不用客气，看看这样是不是可以了。

KDZ

13052565705 发表于 2017-2-7 09:31
不用客气，看看这样是不是可以了。

大师好，这几天不在电脑前，没及时回复，不好意思，您做的代码非常 好，只是还有个小问题：运行代码后实战表的有些列函数被清除了，导致表不能用。现请求：
保留汇总表各列的函数不被清除，这样表格才能实现其它 的计算判断功能。




   另外：现在，汇总表的K列，不要导入数据，因为K列有函数。代码在汇总表中。
麻烦您完善下，谢谢，谢谢，谢谢！！！！