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

linsurvey2005

以下程式碼是我執行單次的方法是正常執行的
可是當資料範圍在不同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

Hsieh

1. Sub test()
   
2.     Dim mtstr As String, Wb As Workbook
   
3.     On Error Resume Next
   
4.     myStr = "選取資料OK後按確定鍵"
   
5.     Set k = Application.InputBox(myStr, Type:=8)  'data範圍
   
6.     If Err Then Exit Sub
   
7.     Set Wb = Workbooks.Add    '開啟新活頁簿
   
8.     ThisWorkbook.Activate
   
9.     k.Copy Wb.ActiveSheet.[A3]
   
10.     Set k = Nothing
    
11.     Do Until Err.Number <> 0
    
12.       Set k = Application.InputBox(myStr, Type:=8) 'data範圍
    
13.       k.Copy Wb.ActiveSheet.[A65536].End(xlUp).Offset(1, 0) '指定儲存格 貼上資料
    
14.       Set k = Nothing
    
15.     Loop
    
16. End Sub

複製代碼

linsurvey2005

謝謝老師回復,再進一步請教老師
我這樣增加行列上去會影響程式的運作嗎?(我跑起來還好只是想了解觀念)
還有我可以在第一次選取資料時就一起顯示"如果要繼續選取請按[繼續]鍵"嗎?
感覺我這樣好像又多一次動作
請老師幫我指正

    Do Until Err.Number <> 0
     Dim Msg1, Style, Response, MyString
      Style = vbYesNo
      Msg1 = "是 / 否 繼續選取資料"
      Response = MsgBox(Msg1, Style)
        If Response = vbYes Then    ' 若使用者按下 [是]。
      Set k = Application.InputBox(myStr, Type:=8) 'data範圍
      k.Copy Wb.ActiveSheet.[A65536].End(xlUp).Offset(1, 0) '指定儲存格 貼上資料
      Set k = Nothing
            Else
             Exit Do    ' 產生相對回應。
        End If
      Loop

Hsieh

1. Sub test()
   
2.     Dim mtstr As String, Wb As Workbook
   
3.     On Error Resume Next
   
4.     myStr = "選取資料OK後按確定鍵"
   
5.     Set k = Application.InputBox(myStr, Type:=8)  'data範圍
   
6.     If Err Then Exit Sub
   
7.     Set Wb = Workbooks.Add    '開啟新活頁簿
   
8.     ThisWorkbook.Activate
   
9.     k.Copy Wb.ActiveSheet.[A3]
   
10.     Set k = Nothing
    
11.     Response = MsgBox("是否繼續", vbYesNo)
    
12.     Do Until Response <> vbYes
    
13.       Set k = Application.InputBox(myStr, Type:=8) 'data範圍
    
14.       k.Copy Wb.ActiveSheet.[A65536].End(xlUp).Offset(1, 0) '指定儲存格 貼上資料
    
15.       Set k = Nothing
    
16.       Response = MsgBox("是否繼續", vbYesNo)
    
17.     Loop
    
18. End Sub

複製代碼

linsurvey2005

感謝老師的再三回覆
請教以下幾行是不是讓物件由"K"畫面(顯示狀態)帶出資料後
插入新活頁簿(隱藏狀態),這樣是提高作業效率的一種嗎?
另外對"K"物件釋放,是不是防止資料多 電腦會卡卡的.
不好意思問題比山高~^.^
Set Wb = Workbooks.Add    '開啟新活頁簿
ThisWorkbook.Activate
k.Copy Wb.ActiveSheet.[A3]
Set k = Nothing

Hsieh

當新的活頁簿開啟時，作用中活頁簿會指向該新增的活頁簿
ThisWorkbook.Activate
確保作用中活頁簿會是程式碼所在之活頁簿
此時新活頁簿仍然是顯示的，只是顯示在下一層視窗

Set k = Nothing
在這邊是必須的，當對話框選擇動作會造成程式出錯時
因前面的On Error Resume Next會讓程序繼續執行，若不釋放k物件
程式在結束時可能會多貼一次未釋放的k物件

linsurvey2005

感謝老師不吝指導,它山之法
我再次增加了開檔行列
繼續選取資料就顯示到選取的活頁簿
如果結束選取就顯示到新的活頁簿
因巨集是在另外一個Excel檔案建立(程式檔.xls)
最主要是希望運作時不要編輯到(程式檔.xls)
但是新增部分就是不會顯示到"新活頁簿"
請老師幫忙指導

Sub testopen()
    F = Application.GetOpenFilename("Excel 檔案(*.xls),*.xls")
    If F = "False" Then Exit Sub
        Workbooks.Open filename:=F
            y = ActiveWorkbook.Name        
    Dim mtstr As String, Wb As Workbook
    On Error Resume Next
        myStr = "選取資料OK後按確定鍵"
    Set k = Application.InputBox(myStr, Type:=8)  'data範圍
    If Err Then Exit Sub
        Set Wb = Workbooks.Add    '開啟新活頁簿
            ThisWorkbook.Activate
                Wb = ActiveWorkbook.Name            
            k.Copy Wb.ActiveSheet.[A3]
        Set k = Nothing
        Response = MsgBox("是 / 否繼續選取", vbYesNo)
    Do Until Response <> vbYes
Windows(y).Activate        
       Set k = Application.InputBox(myStr, Type:=8) 'data範圍
            k.Copy Wb.ActiveSheet.[A65536].End(xlUp).Offset(1, 0) '指定儲存格 貼上資料
        Set k = Nothing
            Response = MsgBox("是 / 否繼續選取", vbYesNo)
    Loop
   
    Application.DisplayAlerts = False
        Windows(y).Close
    Application.DisplayAlerts = True
    Application.ScreenUpdating = False
Windows(Wb).Activate  
.........
.......
....

linsurvey2005

老師可以再指導一下嘛?
好期待內

Hsieh

回復 8# linsurvey2005

已經被你打敗了
被你的說明搞的腦袋打結了
首先你只要確定你要點選是哪個檔案?
點選後複製到哪個檔案?
最簡單就是把這些檔案在開啟時用變數來儲存就能在後續動作指定到正確檔案
再用迴圈來開啟點選窗格(inputbox)，與繼續與否的對話(msgbox)
清楚了解你想要的動作順序就能完成  
因為之前的語法已經包含了開啟新檔，將檔案指定給物件變數，  迴圈點選複製

linsurvey2005

拍謝~我的問題邏輯結構不夠具體造成"腦袋打結"~^.^
還是我給老師看全部的程式碼 這樣比較不會筆誤~^.^
Sub testall()
    F = Application.GetOpenFilename("Excel 檔案(*.xls),*.xls")
       If F = "False" Then Exit Sub
         Workbooks.Open filename:=F
            y = ActiveWorkbook.Name         
    Dim mtstr As String, Wb As Workbook
    On Error Resume Next
      myStr = "選取資料OK後按確定鍵"
    Set k = Application.InputBox(myStr, Type:=8)  'data範圍
         If Err Then Exit Sub
           Set Wb = Workbooks.Add    '開啟新活頁簿
    ThisWorkbook.Activate
         k.Copy Wb.ActiveSheet.[A3]
           Set k = Nothing'釋放物件
              Response = MsgBox("是 / 否繼續選取", vbYesNo)
    Do Until Response <> vbYes
        Windows(y).Activate'回到原選取檔案繼續選取
           Set k = Application.InputBox(myStr, Type:=8) 'data範圍
             k.Copy Wb.ActiveSheet.[A65536].End(xlUp).Offset(1, 0) '指定儲存格 貼上資料
           Set k = Nothing'釋放物件
             Response = MsgBox("是 / 否繼續選取", vbYesNo)
    Loop
   
    Application.DisplayAlerts = False'關閉訊息欄   
       Windows(y).Close' 關閉選取資料檔案
    Application.DisplayAlerts = True'開啟訊息欄
   
   Application.ScreenUpdating = False
        Windows(Wb).Activate '顯示到新活頁簿檔案畫面
        Windows("book1".xls).Activate   '上面那行可以寫成這樣嘛?  
Dim nX As Long, X As Long, I As Integer'以下是在新活頁簿執行
    nX = [A65536].End(xlUp).Row
    For X = nX To 4 Step -1
      For I = 1 To 3
       Rows(X).Insert
      Next
    Next
    bb = (nX - 1) * 4 - 1
    cc = 65536
    Rows(bb & ":" & cc).Clear
    Columns("n") = Columns("n").Value'只顯示表格資料
    Application.Dialogs(xlDialogSaveAs).Show (Format(Date, "yymmdd" & "-Tilt") & "-PDA" & ".xls")'另存新活頁簿檔名
   Windows("程式檔").Close'關閉巨集撰寫檔案(因為我使用巨集小按鈕指定巨集來啟動)應該是老師說的"程式檔"皆再下層執行不要顯示狀態
End Sub
以上 麻煩老師幫我指正~學無止盡,養生平性~^.^