- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
22#
發表於 2013-7-6 07:39
| 只看該作者
回復 21# linsurvey2005
再試試看- Option Explicit
- Sub Selection_Copy()
- Dim fs As String, Nwb As Workbook, SourceWb As Workbook, R As Integer, k As Range, myfilename As String
- On Error GoTo 11 '程執行式如有錯誤.到 標記12:處裡
- fs = Application.GetOpenFilename("Excel 檔案(*.xls),*.xls")
- If fs = "False" Then Exit Sub
- Set SourceWb = Workbooks.Open(fs)
- Set k = Application.InputBox("選取傾斜->墩柱編號,里程,方向及初使值,前次監測值", Type:=8) '物件:Range:如取消InputBox的輸入->k不為物件錯誤值=1004
- Set Nwb = Workbooks.Add
- With Nwb.Sheets(1) '物件:新增活頁簿的第1個工作表
- '新增活頁簿時,作用中的活頁簿會移到此新增活頁簿
- SourceWb.Activate '作用中的活頁簿:此活頁簿(SourceWb)
- Do
- R = Application.Max(3, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
- k.Copy .Cells(R, 1) '複製所選起的的範圍
- If MsgBox("是否繼續", vbYesNo) = vbNo Then Exit Do
- Set k = Application.InputBox("選取傾斜->墩柱編號,里程,方向及初使值,前次監測值", Type:=8) '物件:Range:如取消InputBox的輸入->k不為物件錯誤值=1004
- Loop
- 9:
- .Activate
- DoEvents
- myfilename = Format(Date, "yymmdd") & "-Tilt-PDA.xls"
- Application.SendKeys myfilename, True
- fs = Application.GetSaveAsFilename("E:\")
- If fs <> False Then .Parent.SaveAs fs
- .Parent.Close 0
- End With
- 10:
- SourceWb.Close 0
- Exit Sub
- 11:
- If Err = 424 Then
- If Nwb.Sheets(1).UsedRange.Rows.Count > 1 Then GoTo 9 '已有選擇範圍過:新增活頁簿需存檔
- GoTo 10
- End If
- k.Select
- MsgBox "所選的 " & k.Areas.Count & " 範圍:不在同一列上,列數不相等", , "不可複製!!"
- Resume Next '回到程式碼錯誤行的下一行
- End Sub
|
|
發表於 2013-7-4 17:16
| 
