linsurvey2005

回復 20# GBKEE


    大大好 真是抱歉馬上上傳檔案 1資料檔  2完成檔會自己產生
我要選取的資料為 a5:E68,BH5:BI68
選取完成之後將會有七列資料 放置新檔案 然後資料自動進行排序 最後儲存檔名

GBKEE

回復 21# linsurvey2005
再試試看

1. Option Explicit
   
2. Sub Selection_Copy()
   
3.     Dim fs As String, Nwb As Workbook, SourceWb As Workbook, R As Integer, k As Range, myfilename As String
   
4.     On Error GoTo 11                                                                                 '程執行式如有錯誤.到 標記12:處裡
   
5.     fs = Application.GetOpenFilename("Excel 檔案(*.xls),*.xls")
   
6.     If fs = "False" Then Exit Sub
   
7.     Set SourceWb = Workbooks.Open(fs)
   
8.     Set k = Application.InputBox("選取傾斜->墩柱編號,里程,方向及初使值,前次監測值", Type:=8)        '物件:Range:如取消InputBox的輸入->k不為物件錯誤值=1004
   
9.     Set Nwb = Workbooks.Add
   
10.     With Nwb.Sheets(1)                                                                              '物件:新增活頁簿的第1個工作表
    
11.         '新增活頁簿時,作用中的活頁簿會移到此新增活頁簿
    
12.         SourceWb.Activate                                                                           '作用中的活頁簿:此活頁簿(SourceWb)
    
13.         Do
    
14.             R = Application.Max(3, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
    
15.             k.Copy .Cells(R, 1)                                                                     '複製所選起的的範圍
    
16.             If MsgBox("是否繼續", vbYesNo) = vbNo Then Exit Do
    
17.             Set k = Application.InputBox("選取傾斜->墩柱編號,里程,方向及初使值,前次監測值", Type:=8) '物件:Range:如取消InputBox的輸入->k不為物件錯誤值=1004
    
18.         Loop
    
19. 9:
    
20.         .Activate
    
21.         DoEvents
    
22.         myfilename = Format(Date, "yymmdd") & "-Tilt-PDA.xls"
    
23.         Application.SendKeys myfilename, True
    
24.         fs = Application.GetSaveAsFilename("E:\")
    
25.         If fs <> False Then .Parent.SaveAs fs
    
26.         .Parent.Close 0
    
27.     End With
    
28. 10:
    
29.     SourceWb.Close 0
    
30.     Exit Sub
    
31. 11:
    
32.     If Err = 424 Then
    
33.         If Nwb.Sheets(1).UsedRange.Rows.Count > 1 Then GoTo 9                                         '已有選擇範圍過:新增活頁簿需存檔
    
34.         GoTo 10
    
35.     End If
    
36.     k.Select
    
37.     MsgBox "所選的 " & k.Areas.Count & " 範圍:不在同一列上,列數不相等", , "不可複製!!"
    
38.     Resume Next                                                                                          '回到程式碼錯誤行的下一行
    
39. End Sub

複製代碼

linsurvey2005

回復 22# GBKEE


    謝謝大大，編修之後選取儲存格可以正常呈現，但是點選"否"出現狀況，詳圖片
(請問大大 出現狀況這一行是告訴我再選擇資料用的嗎?)