[已解决]请教工作簿间复制数据

yizhih

请教工作簿间复制数据。谢谢！
工作簿1向工作簿2转移数据.rar (62.95 KB, 下载次数: 12)

2013-5-6 16:32 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-5-7 12:41

1. Sub 按钮2_Click()
   
2.     Dim wbDst As Workbook
   
3.     Dim lCol As Long
   
4.     Dim lShtNumber As Long
   
5.     On Error GoTo ErrorHandler
   
6. 
   
7.     Application.ScreenUpdating = False
   
8.     Application.DisplayAlerts = False
   
9.     Set wbDst = GetObject(ThisWorkbook.Path & Application.PathSeparator & "工作簿2.xls")
   
10. 
    
11.     With Worksheets("sheet10")
    
12.         Debug.Print "sheet10"
    
13.         For lCol = 84 To 99 Step 3
    
14.             lShtNumber = lShtNumber + 1
    
15.             'Debug.Print lCol, lShtNumber, lShtNumber + 12
    
16.             With wbDst
    
17.                 .Worksheets("sheet" & lShtNumber).UsedRange.Clear
    
18.                 .Worksheets("sheet" & lShtNumber + 12).UsedRange.Clear
    
19.             End With
    
20.             .Range(.Cells(3, lCol), .Cells(3, lCol).End(xlDown)).Copy
    
21.             With wbDst
    
22.                 .Worksheets("sheet" & lShtNumber).Cells(2, 2).PasteSpecial Transpose:=True
    
23.                 .Worksheets("sheet" & lShtNumber + 12).Cells(2, 2).PasteSpecial Transpose:=True
    
24.             End With
    
25.             Application.CutCopyMode = False
    
26.         Next
    
27.     End With
    
28. 
    
29.     lShtNumber = 7
    
30.     With Worksheets("sheet18")
    
31.         'Debug.Print "sheet18"
    
32.         For lCol = 84 To 99 Step 3
    
33.             'Debug.Print lCol, lShtNumber, lShtNumber + 6
    
34.             With wbDst
    
35.                 .Worksheets("sheet" & lShtNumber).UsedRange.Clear
    
36.                 '.Worksheets("sheet" & lShtNumber + 6).UsedRange.Clear
    
37.             End With
    
38.             .Range(.Cells(3, lCol), .Cells(3, lCol).End(xlDown)).Copy
    
39.             With wbDst
    
40.                 .Worksheets("sheet" & lShtNumber).Cells(2, 2).PasteSpecial Transpose:=True
    
41.                 .Worksheets("sheet" & lShtNumber + 6).Cells(3, 2).PasteSpecial Transpose:=True
    
42.             End With
    
43.             lShtNumber = lShtNumber + 1
    
44.             Application.CutCopyMode = False
    
45.         Next
    
46.     End With
    
47.    
    
48.     Application.ScreenUpdating = True
    
49.     MsgBox "复制完成"
    
50.     Application.DisplayAlerts = False
    
51.     wbDst.Close True
    
52.     Application.DisplayAlerts = True
    
53.     Exit Sub
    
54. 
    
55. ErrorHandler:
    
56.     MsgBox Err.Number & vbCrLf & _
    
57.            Err.Description
    
58. End Sub

复制代码

第二次清除多余了，所以没有了，

跳转到最佳答案楼层

yizhih

顶~~~~~~~~~~~~~~~~~~~~~~

yizhih

顶~~~~~~~~~~~~~~

hwc2ycy

怎么个转移法？
需要格式不？

yizhih

hwc2ycy 发表于 2013-5-7 09:00
怎么个转移法？
需要格式不？

工作簿1向工作簿2复制数据，工作簿2内的数据是复制后的样子，最好是带格式复制到工作簿2。
我的标题写的不确切，好像写“转移”不确切，应该是“复制”。

hwc2ycy

1. Sub 按钮2_Click()
   
2.     Dim wbDst As Workbook
   
3.     Dim lCol As Long
   
4.     Dim lShtNumber As Long
   
5.     On Error GoTo ErrorHandler
   
6. 
   
7.     Application.ScreenUpdating = False
   
8.     Application.DisplayAlerts = False
   
9.     Set wbDst = GetObject(ThisWorkbook.Path & Application.PathSeparator & "工作簿2.xls")
   
10.     With Worksheets("sheet10")
    
11.         Debug.Print "sheet10"
    
12.         For lCol = 84 To 99 Step 3
    
13.             lShtNumber = lShtNumber + 1
    
14.             Debug.Print lCol, lShtNumber, lShtNumber + 12
    
15.             .Range(.Cells(3, lCol), .Cells(3, lCol).End(xlDown)).Copy
    
16.             With wbDst
    
17.                 .Worksheets("sheet" & lShtNumber).Cells(Rows.Count, 2).End(xlUp).Offset(2).PasteSpecial Transpose:=True
    
18.                 .Worksheets("sheet" & lShtNumber + 12).Cells(Rows.Count, 2).End(xlUp).Offset(2).PasteSpecial Transpose:=True
    
19.             End With
    
20.             Application.CutCopyMode = False
    
21.         Next
    
22.     End With
    
23.     lShtNumber = 7
    
24.     With Worksheets("sheet18")
    
25.         Debug.Print "sheet18"
    
26.         For lCol = 84 To 99 Step 3
    
27.             Debug.Print lCol, lShtNumber, lShtNumber + 6
    
28.             .Range(.Cells(3, lCol), .Cells(3, lCol).End(xlDown)).Copy
    
29.             With wbDst
    
30.                 .Worksheets("sheet" & lShtNumber).Cells(Rows.Count, 2).End(xlUp).Offset(3).PasteSpecial Transpose:=True
    
31.                 .Worksheets("sheet" & lShtNumber + 6).Cells(Rows.Count, 2).End(xlUp).Offset(3).PasteSpecial Transpose:=True
    
32.             End With
    
33.             lShtNumber = lShtNumber + 1
    
34.             Application.CutCopyMode = False
    
35.         Next
    
36.     End With
    
37.     Application.ScreenUpdating = True
    
38.     MsgBox "复制完成"
    
39.     wbDst.Close True
    
40.     Exit Sub
    
41. ErrorHandler:
    
42.     MsgBox Err.Number & vbCrLf & _
    
43.            Err.Description
    
44. End Sub

复制代码

hwc2ycy

你把代码试下，有问题再改。

yizhih

hwc2ycy 发表于 2013-5-7 09:35

感谢 hwc2ycy 老师，有些小问题请修改一下：
1、对于工作簿2的Sheet1-12表，请把数据复制到以B2开始的第二行。
2、对于工作簿2的Sheet13-18表，请把数据分别复制到以B2开始的第二行和以B3开始的第三行，具体是工作簿1的Sheet10表的数据复制到以B2开始的第二行，工作簿1的Sheet18表的数据复制到以B3开始的第三行。

hwc2ycy

yizhih 发表于 2013-5-7 09:52
感谢 hwc2ycy 老师，有些小问题请修改一下：
1、对于工作簿2的Sheet1-12表，请把数据复制到以B2开始的第 ...

啥叫B2开始的第2行，B4么？

hwc2ycy

第2个问题：

1.             With wbDst
   
2.                 .Worksheets("sheet" & lShtNumber).Cells(Rows.Count, 2).End(xlUp).Offset(2).PasteSpecial Transpose:=True
   
3.                 .Worksheets("sheet" & lShtNumber + 6).Cells(Rows.Count, 2).End(xlUp).Offset(3).PasteSpecial Transpose:=True

复制代码