123
返回列表 上一主題 發帖

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

linsurvey2005

帖子
84 
主題
15 
精華
0 
積分
123 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2010 
閱讀權限
20 
性別
男 
來自
台南市 
註冊時間
2011-5-16 
最後登錄
2022-9-17 
1# 跳轉到 » 正序看帖
打印
tT
發表於 2011-6-3 21:50 | 只看該作者

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

以下程式碼是我執行單次的方法是正常執行的
可是當資料範圍在不同sheet就麻煩了
因為我指定了位址Range("A3").Select給他
想要讓資料有一直圈選往後增加
一直到按取消然後繼續執行後面程式
若能指正程式的碼編方式 我會更高興~多學一招會更好睡覺~^.^

Sub test()
    Dim mtstr As String
    myStr = "選取資料OK後按確定鍵"
    On Error Resume Next
    Set k = Application.InputBox(myStr, Type:=8)  'data範圍
    p = k.Copy
    Workbooks.Add     '開啟新活頁簿
    Range("A3").Select '指定儲存格
    ActiveSheet.Paste  '貼上資料
    If Err Then
          Err.Clear
    Exit Sub
    End If
End Sub
收藏 分享
開心學習,學習很開心

linsurvey2005

帖子
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)

測試後狀況.jpg

開心學習,學習很開心

TOP

GBKEE

帖子
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
再試試看
  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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

linsurvey2005

帖子
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)

開心學習,學習很開心

TOP

GBKEE

帖子
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元的贊助,人人有能力.

TOP

linsurvey2005

帖子
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)

開心學習,學習很開心

TOP

GBKEE

帖子
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元的贊助,人人有能力.

TOP

linsurvey2005

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

感謝有三
開心學習,學習很開心

TOP

GBKEE

帖子
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#的程式碼試試看
  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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

linsurvey2005

帖子
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+相對儲存格數目
開心學習,學習很開心

TOP

        靜思自在 : 難行能行，難捨能捨，難為能為，才能昇華自我的人格。
123
返回列表 上一主題