簿间传输

ddz79101

老师！有2个工作簿，我希望将数据簿中的三表未涂色的区域数据（数值）传输到上传簿中，望老师指导。谢谢

ddz79101

有老师看看吗

aodo

这么简单，自己录个宏也能解决了吧，你是EH高级呢

ddz79101

aodo 发表于 2024-9-5 11:52
这么简单，自己录个宏也能解决了吧，你是EH高级呢

谢谢老师！试过了，复制不行，只有用提取的办法

ddz79101

有老师帮忙看看嘛

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim wb As Workbook
   
5.     Dim ws As Worksheet
   
6.     Dim mypath$, myname$
   
7.     Application.ScreenUpdating = False
   
8.     Application.DisplayAlerts = False
   
9.     mypath = ThisWorkbook.Path & ""
   
10.     myname = "上报.xls"
    
11.     If Dir(mypath & myname) = "" Then
    
12.         MsgBox mypath & myname & "不存在！"
    
13.         Exit Sub
    
14.     End If
    
15.     Set wb = GetObject(mypath & myname)
    
16.     Windows(wb.Name).Visible = True
    
17.     With ThisWorkbook
    
18.         With .Worksheets("资产表")
    
19.             .Range("c2:d33").Copy wb.Worksheets("资产表").Range("c2")
    
20.             .Range("g2:h33").Copy wb.Worksheets("资产表").Range("g2")
    
21.         End With
    
22.         With .Worksheets("利润表")
    
23.             .Range("c2:d33").Copy wb.Worksheets("资产表").Range("c2")
    
24.         End With
    
25.         With .Worksheets("现金表")
    
26.             .Range("c2:d26").Copy wb.Worksheets("资产表").Range("c2")
    
27.         End With
    
28.     End With
    
29.     With wb
    
30.         .Close True
    
31.     End With
    
32.     Application.ScreenUpdating = True
    
33.     MsgBox "数据上传成功！"
    
34. End Sub
    

复制代码

chxw68

详见附件。

ddz79101

chxw68 发表于 2024-9-5 14:21
详见附件。

谢谢老师！我现在就看，能否导入

ddz79101

chxw68 发表于 2024-9-5 14:21
详见附件。

谢谢老师！导出成功

Qs18

1. Sub qs()
   
2.     Dim wb As Workbook, xb As Workbook, p As String, ar, a
   
3.     Set wb = ThisWorkbook
   
4.     p = wb.Path & ""
   
5.     Set xb = Workbooks.Open(p & "数据.xls", 0)
   
6.     ar = [{"资产表","利润表","现金表"}]
   
7.     For Each a In ar
   
8.         xb.Sheets(a).Range("a1").CurrentRegion.Copy
   
9.         wb.Sheets(a).Range("a1").PasteSpecial Paste:=xlPasteValues
   
10.         Application.CutCopyMode = False
    
11.     Next
    
12.     xb.Close (0)
    
13.     Set wb = Nothing: Set xb = Nothing
    
14.     MsgBox "完成！"
    
15. End Sub
    

复制代码