[已解决]请问怎么编VBA可以自动把表格数据粘贴到其它对应名字工作表对应位置上

ellick1988

如题：
请问怎么编VBA可以自动把表格数据粘贴到其它对应名字工作表对应位置上？
求教大神！ 怎么把数据台账内的表格数据自动粘贴到文件夹内对应名字的Excel工作表对应的固定位置上？
新建文件夹.rar (28.38 KB, 下载次数: 40)

2016-4-8 11:09 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

dsmch

2016-4-10 09:55

1. Sub Macro1()
   
2. On Error Resume Next
   
3. mypath = ThisWorkbook.Path & ""
   
4. Set sht = ThisWorkbook.Sheets("数据台账")
   
5. Application.ScreenUpdating = False
   
6. For i = 1 To 19 Step 9
   
7.     With Workbooks.Open(mypath & sht.Cells(i, 1) & ".xls")
   
8.         .Sheets(1).[i7].Resize(9, 7).Value = sht.Cells(i, 2).Resize(9, 7).Value
   
9.         .Close 1
   
10.     End With
    
11. Next
    
12. MsgBox "OK"
    
13. Application.ScreenUpdating = True
    
14. End Sub

复制代码

跳转到最佳答案楼层

sry660

1. Sub 复制数据()
   
2.     Dim arr, x%
   
3.     Dim Na$, Nam$, Wb As Workbook, Sh As Worksheet, Mypath$
   
4.     Mypath = ThisWorkbook.Path & ""
   
5.     Na = Dir(Mypath & "*.xls")
   
6.     Application.ScreenUpdating = False
   
7.     Do While Na <> ""
   
8.         If Na <> ThisWorkbook.Name Then
   
9.             x = Val(Mid(Na, 3))
   
10.             arr = Cells(x * 9 - 8, 2).Resize(9, 7)
    
11.             Nam = Mypath & Na
    
12.             Set Wb = Workbooks.Open(Nam)
    
13.             With Wb
    
14.                 .Sheets(1).[i7].Resize(9, 7) = arr
    
15.                 .Close True
    
16.             End With
    
17.         End If
    
18.         Na = Dir
    
19.     Loop
    
20.     MsgBox "复制完毕，共复制：" & x & "组数据！"
    
21.     Application.ScreenUpdating = True
    
22. End Sub

复制代码

ellick1988

sry660 发表于 2016-4-8 12:22

老师 我测试了下 发现数据只能按表格顺序粘贴到其它表格里，而不是对应名字对应表格，因为我试着把数据里的表格名字次序更改了 填入表格的顺序还是从上到下的进行，请问能做到检索名字，然后一一对应填入吗？  辛苦了 老师

dsmch

1. Sub Macro1()
   
2. On Error Resume Next
   
3. mypath = ThisWorkbook.Path & ""
   
4. Set sht = ThisWorkbook.Sheets("数据台账")
   
5. Application.ScreenUpdating = False
   
6. For i = 1 To 19 Step 9
   
7.     With Workbooks.Open(mypath & sht.Cells(i, 1) & ".xls")
   
8.         .Sheets(1).[i7].Resize(9, 7).Value = sht.Cells(i, 2).Resize(9, 7).Value
   
9.         .Close 1
   
10.     End With
    
11. Next
    
12. MsgBox "OK"
    
13. Application.ScreenUpdating = True
    
14. End Sub

复制代码

ellick1988

dsmch 发表于 2016-4-10 09:55

谢谢 老师 你i的回答很好的满足了我的要求！ 谢谢！