Hsieh

回復 10# linsurvey2005

試試看這樣是不是你要的

1. Sub Selection_Copy()
   
2. Dim fs$, SRng, SourceWb As Workbook
   
3. fs = Application.GetOpenFilename("Excel 檔案(*.xls),*.xls")
   
4. Set SourceWb = Workbooks.Open(fs)
   
5. k = Application.InputBox("請選取欲複製的範圍", , , , , , , 8)
   
6. If TypeName(k) = "Boolean" Then SourceWb.Close 0: Exit Sub
   
7. Set nwb = Workbooks.Add
   
8. With nwb.Sheets(1)
   
9. .Activate
   
10. r = Application.Max(12, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
    
11. If IsArray(k) Then
    
12. .Cells(r, 1).Resize(UBound(k, 1), UBound(k, 2)) = k
    
13. Else
    
14. .Cells(r, 1) = k
    
15. End If
    
16. yn = MsgBox("是否繼續", vbYesNo): GoTo 10
    
17. Do Until yn <> 6 Or TypeName(k) = "Boolean"
    
18. r = Application.Max(12, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
    
19. If IsArray(k) Then
    
20. .Cells(r, 1).Resize(UBound(k, 1), UBound(k, 2)) = k
    
21. Else
    
22. .Cells(r, 1) = k
    
23. End If
    
24. yn = MsgBox("是否繼續", vbYesNo)
    
25. 10
    
26. If yn = 6 Then SourceWb.Activate: k = Application.InputBox("請選取欲複製的範圍", , , , , , , 8)
    
27. Loop
    
28. nwb.Activate
    
29. DoEvents
    
30. myfilename = Format(Date, "yymmdd") & "-Tilt-PDA.xls"
    
31. Application.SendKeys myfilename, True
    
32. sf = Application.GetSaveAsFilename("E:\")
    
33. If sf <> False Then nwb.SaveAs sf
    
34. SourceWb.Close 0
    
35. End With
    
36. End Sub

複製代碼

linsurvey2005

好讚~這種有教無淚的精神(五體投地)
程式碼的效果有如99.99純金
嚇死我了~太強了
再次詢問
If TypeName(k) = "Boolean" Then SourceWb.Close 0: Exit Sub
這句SourceWb.Close 0  是用來關掉  開啟的檔案嗎?

myfilename = Format(Date, "yymmdd") & "-Tilt-PDA.xls"
原來句子這樣子就可以了
等我積分充足我就去下載老師的"一些vba常用語法範例"
接觸VBA快2年了沒基本底子
很多東湊西湊的程式碼
該是要正面接觸的時候了
加入論壇很開心
感謝老師不吝指導
以上

linsurvey2005

回復 11# Hsieh


老師好
執行資料選取的時候，按ctrl+"A1:E50","G1:H50"
資料顯示合併為A1:C50,G1:H50(D1:E50的資料已被G1:H50蓋過)
我想讓資料合併為A1:E50,G1:H50
幫忙解惑

GBKEE

回復 12# linsurvey2005

這句SourceWb.Close 0  是用來關掉  開啟的檔案嗎?

SourceWb.Close 0 -> SourceWb.Close False ( 檔案關閉:  不儲存檔案)
SourceWb.Close 1 -> SourceWb.Close True   (檔案關閉:  儲存檔案)

回復 13# linsurvey2005

下載 (22.07 KB)

2013-7-2 09:44

linsurvey2005

回復 14# GBKEE

謝謝大大小解
另有一大未解，就是 11# 程式裡面的選取資料不能使用ctrl+相對儲存格數目

GBKEE

回復 15# linsurvey2005
不了解你的涵義: 13# 資料顯示合併為A1:C50,G1:H50(D1:E50的資料已被G1:H50蓋過),我想讓資料合併為A1:E50,G1:H50
ctrl+相對儲存格數目 => 選取多重的範圍
修改Hsieh超版  11#的程式碼試試看

1. Option Explicit
   
2. Sub Selection_Copy()
   
3.     Dim fs$, SRng As Range, SourceWb As Workbook, r As Integer, k As Range, myfilename As String
   
4.     On Error Resume Next
   
5.     fs = Application.GetOpenFilename("Excel 檔案(*.xls),*.xls")
   
6.     Set SourceWb = Workbooks.Open(fs)
   
7.     Set k = Application.InputBox("請選取欲複製的範圍", , , , , , , 8)       '物件:Range
   
8.     If Err.Number <> 0 Then GoTo 10                                         '取消InputBox的輸入->k不為物件會有錯誤
   
9.     With Workbooks.Add.Sheets(1)                                            '物件:新增活頁簿的第1個工作表
   
10.         '新增活頁簿時,作用中的活頁簿會移到此新增活頁簿
    
11.         SourceWb.Activate                                                    '作用中的活頁簿:此活頁簿
    
12.         Do
    
13.             For Each SRng In k.Areas                                         'Areas 集合，此集合代表多重範圍中的所有範圍
    
14.                 r = Application.Max(12, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
    
15.                 .Cells(r, 1).Resize(SRng.Rows.Count, SRng.Columns.Count) = SRng.Value
    
16.             Next
    
17.             If MsgBox("是否繼續", vbYesNo) = vbNo Then Exit Do
    
18.             Set k = Application.InputBox("請選取欲複製的範圍", , , , , , , 8)
    
19.             If Err.Number <> 0 Then Exit Do                                   '取消InputBox的輸入->k不為物件會有錯誤
    
20.         Loop
    
21.         .Activate
    
22.         DoEvents
    
23.         myfilename = Format(Date, "yymmdd") & "-Tilt-PDA.xls"
    
24.         Application.SendKeys myfilename, True
    
25.        fs = Application.GetSaveAsFilename("E:\")
    
26.         If fs <> False Then .Parent.SaveAs fs
    
27.         .Parent.Close 0
    
28.     End With
    
29. 10:
    
30.     SourceWb.Close 0
    
31. End Sub

複製代碼

linsurvey2005

回復 16# GBKEE


    大大好 無法順利選取資料 我說明一下程式碼內容

第一步驟 是先點選所要的Excel檔案
第二步驟 開始選取所要的資料(因為資料有累積值，想把第一筆 跟 第四筆 跟 第七筆資料一起選取)
第三步驟 選擇資料不足的話可以繼續進行資料選取(再次選取的資料需要堆疊到先前抓取的)
第四步驟 進行存檔

感謝有三

GBKEE

回復 17# linsurvey2005

[  看的一頭霧水  ]

linsurvey2005

回復 18# GBKEE


大大說的真是到味
我直接上傳給大大過目即可知道問題出在哪裡
檔案程式碼有添加個人的構想，感謝

GBKEE

回復 19# linsurvey2005
還是 [  看的一頭霧水  ],尚缺: 1.資料檔,2.完成檔(你的構想) 的範例.