[發問] 求助建立迴圈應用

帖子: 84
主題: 15
精華: 0
積分: 123
點名: 0
作業系統: Windows 7
軟體版本: Office 2010
閱讀權限: 20
性別: 男
來自: 台南市
註冊時間: 2011-5-16
最後登錄: 2022-9-17

23^#

發表於 2013-7-8 17:20 | 只看該作者

回復 22# GBKEE

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

測試後狀況.jpg (61.7 KB)

開心學習,學習很開心

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

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

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

帖子: 84
主題: 15
精華: 0
積分: 123
點名: 0
作業系統: Windows 7
軟體版本: Office 2010
閱讀權限: 20
性別: 男
來自: 台南市
註冊時間: 2011-5-16
最後登錄: 2022-9-17

21^#

發表於 2013-7-4 17:16 | 只看該作者

回復 20# GBKEE

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

1(資料檔).zip (38.1 KB)

開心學習,學習很開心

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

20^#

發表於 2013-7-4 10:02 | 只看該作者

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

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

帖子: 84
主題: 15
精華: 0
積分: 123
點名: 0
作業系統: Windows 7
軟體版本: Office 2010
閱讀權限: 20
性別: 男
來自: 台南市
註冊時間: 2011-5-16
最後登錄: 2022-9-17

19^#

發表於 2013-7-4 08:37 | 只看該作者

回復 18# GBKEE

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

Tilt.zip (17.59 KB)

開心學習,學習很開心

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

18^#

發表於 2013-7-4 05:27 | 只看該作者

回復 17# linsurvey2005

[ 看的一頭霧水 ]

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

帖子: 84
主題: 15
精華: 0
積分: 123
點名: 0
作業系統: Windows 7
軟體版本: Office 2010
閱讀權限: 20
性別: 男
來自: 台南市
註冊時間: 2011-5-16
最後登錄: 2022-9-17

17^#

發表於 2013-7-3 21:48 | 只看該作者

回復 16# GBKEE

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

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

感謝有三

開心學習,學習很開心

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

16^#

發表於 2013-7-3 07:47 | 只看該作者

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

Option Explicit
Sub Selection_Copy()
Dim fs$, SRng As Range, SourceWb As Workbook, r As Integer, k As Range, myfilename As String
On Error Resume Next
fs = Application.GetOpenFilename("Excel 檔案(*.xls),*.xls")
Set SourceWb = Workbooks.Open(fs)
Set k = Application.InputBox("請選取欲複製的範圍", , , , , , , 8) '物件:Range
If Err.Number <> 0 Then GoTo 10 '取消InputBox的輸入->k不為物件會有錯誤
With Workbooks.Add.Sheets(1) '物件:新增活頁簿的第1個工作表
'新增活頁簿時,作用中的活頁簿會移到此新增活頁簿
SourceWb.Activate '作用中的活頁簿:此活頁簿
Do
For Each SRng In k.Areas 'Areas 集合，此集合代表多重範圍中的所有範圍
r = Application.Max(12, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
.Cells(r, 1).Resize(SRng.Rows.Count, SRng.Columns.Count) = SRng.Value
Next
If MsgBox("是否繼續", vbYesNo) = vbNo Then Exit Do
Set k = Application.InputBox("請選取欲複製的範圍", , , , , , , 8)
If Err.Number <> 0 Then Exit Do '取消InputBox的輸入->k不為物件會有錯誤
Loop
.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
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

帖子: 84
主題: 15
精華: 0
積分: 123
點名: 0
作業系統: Windows 7
軟體版本: Office 2010
閱讀權限: 20
性別: 男
來自: 台南市
註冊時間: 2011-5-16
最後登錄: 2022-9-17

15^#

發表於 2013-7-2 16:48 | 只看該作者

回復 14# GBKEE

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

開心學習,學習很開心