求助代码：两个文件数据复制

昌吉吉

    请教各位老师，我打算把文件名为“CB"的所有工作表中”A3”值与另一个文件名为“新成本单样表”中所有工作表中“A3"值相等的相况下，把”CB"文件中的工作表“D16：P17"与”R16:W17"中的数据，按纯数值形式，复制到"新成本单样表“中对应工作表中的”D12:P13"与“R12:W13”中。谢谢各位老师指点

bosslxt

编了一个，可以试用下：

1. Sub 两个文件数据复制()
   
2. Dim WB1 As Workbook, WB2 As Workbook, SH As Worksheet, Rng As Range
   
3. 
   
4. '查找“CB”文件，如没有打开，则打开该文件，并设为对象WB1
   
5. For Each WB1 In Workbooks
   
6. If WB1.Name Like "CB.xl*" Then GoTo NextProgram_1
   
7. Next
   
8. With Application.FileDialog(msoFileDialogFilePicker)
   
9. .Title = "请指定对比文件"
   
10. .AllowMultiSelect = False
    
11. .Show
    
12. If .SelectedItems.Count = 0 Then Exit Sub '未选择文件
    
13. Application.ScreenUpdating = False
    
14. Workbooks.Open Filename:=.SelectedItems(1)
    
15. Set WB1 = ActiveWorkbook
    
16. End With
    
17. NextProgram_1:
    
18. 
    
19. '查找“新成本单样表”文件，如没有打开，则打开该文件，并设为对象WB2
    
20. For Each WB2 In Workbooks
    
21. If WB2.Name Like "新成本单样表.xl*" Then GoTo NextProgram_2
    
22. Next
    
23. With Application.FileDialog(msoFileDialogFilePicker)
    
24. .Title = "请指定目标文件"
    
25. .AllowMultiSelect = False
    
26. .Show
    
27. If .SelectedItems.Count = 0 Then Exit Sub '未选择文件
    
28. Application.ScreenUpdating = False
    
29. Workbooks.Open Filename:=.SelectedItems(1)
    
30. Set WB2 = ActiveWorkbook
    
31. End With
    
32. NextProgram_2:
    
33. 
    
34. Application.ScreenUpdating = False
    
35. WB2.Activate
    
36. For Each SH In WB2.Sheets
    
37. SH.Select
    
38. If SH.Range("A3").Value = WB1.Sheets(SH.Name).Range("A3").Value Then
    
39. For Each Rng In SH.Range("D12:P13", "R12:W13")
    
40. Rng.Value = WB1.Sheets(SH.Name).Range(Rng.Offset(4, 4).Address).Value
    
41. Next
    
42. End If
    
43. Next
    
44. 
    
45. Application.ScreenUpdating = True
    
46. End Sub

复制代码