123
返回列表 上一主題 發帖

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

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
14# 跳轉到 »
發表於 2013-7-2 09:45 | 只看該作者
回復 12# linsurvey2005

這句SourceWb.Close 0  是用來關掉  開啟的檔案嗎?

SourceWb.Close 0 -> SourceWb.Close False ( 檔案關閉:  不儲存檔案)
SourceWb.Close 1 -> SourceWb.Close True   (檔案關閉:  儲存檔案)

回復 13# linsurvey2005

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

TOP

linsurvey2005

帖子
84 
主題
15 
精華
0 
積分
123 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2010 
閱讀權限
20 
性別
男 
來自
台南市 
註冊時間
2011-5-16 
最後登錄
2022-9-17 
13#
發表於 2013-7-2 08:33 | 只看該作者
回復 11# Hsieh


老師好
執行資料選取的時候，按ctrl+"A1:E50","G1:H50"
資料顯示合併為A1:C50,G1:H50(D1:E50的資料已被G1:H50蓋過)
我想讓資料合併為A1:E50,G1:H50
幫忙解惑
開心學習,學習很開心

TOP

linsurvey2005

帖子
84 
主題
15 
精華
0 
積分
123 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2010 
閱讀權限
20 
性別
男 
來自
台南市 
註冊時間
2011-5-16 
最後登錄
2022-9-17 
12#
發表於 2011-6-6 14:01 | 只看該作者
好讚~這種有教無淚的精神(五體投地)
程式碼的效果有如99.99純金
嚇死我了~太強了
再次詢問
If TypeName(k) = "Boolean" Then SourceWb.Close 0: Exit Sub
這句SourceWb.Close 0  是用來關掉  開啟的檔案嗎?

myfilename = Format(Date, "yymmdd") & "-Tilt-PDA.xls"
原來句子這樣子就可以了
等我積分充足我就去下載老師的"一些vba常用語法範例"
接觸VBA快2年了沒基本底子
很多東湊西湊的程式碼
該是要正面接觸的時候了
加入論壇很開心
感謝老師不吝指導
以上
開心學習,學習很開心

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
253  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-11-22 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
11#
發表於 2011-6-6 11:06 | 只看該作者
回復 10# linsurvey2005

試試看這樣是不是你要的
  1. Sub Selection_Copy()
  2. Dim fs$, SRng, SourceWb As Workbook
  3. fs = Application.GetOpenFilename("Excel 檔案(*.xls),*.xls")
  4. Set SourceWb = Workbooks.Open(fs)
  5. k = Application.InputBox("請選取欲複製的範圍", , , , , , , 8)
  6. If TypeName(k) = "Boolean" Then SourceWb.Close 0: Exit Sub
  7. Set nwb = Workbooks.Add
  8. With nwb.Sheets(1)
  9. .Activate
  10. r = Application.Max(12, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
  11. If IsArray(k) Then
  12. .Cells(r, 1).Resize(UBound(k, 1), UBound(k, 2)) = k
  13. Else
  14. .Cells(r, 1) = k
  15. End If
  16. yn = MsgBox("是否繼續", vbYesNo): GoTo 10
  17. Do Until yn <> 6 Or TypeName(k) = "Boolean"
  18. r = Application.Max(12, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
  19. If IsArray(k) Then
  20. .Cells(r, 1).Resize(UBound(k, 1), UBound(k, 2)) = k
  21. Else
  22. .Cells(r, 1) = k
  23. End If
  24. yn = MsgBox("是否繼續", vbYesNo)
  25. 10
  26. If yn = 6 Then SourceWb.Activate: k = Application.InputBox("請選取欲複製的範圍", , , , , , , 8)
  27. Loop
  28. nwb.Activate
  29. DoEvents
  30. myfilename = Format(Date, "yymmdd") & "-Tilt-PDA.xls"
  31. Application.SendKeys myfilename, True
  32. sf = Application.GetSaveAsFilename("E:\")
  33. If sf <> False Then nwb.SaveAs sf
  34. SourceWb.Close 0
  35. End With
  36. End Sub
複製代碼
學海無涯_不恥下問

TOP

linsurvey2005

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

拍謝~我的問題邏輯結構不夠具體造成"腦袋打結"~^.^
還是我給老師看全部的程式碼 這樣比較不會筆誤~^.^
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
以上 麻煩老師幫我指正~學無止盡,養生平性~^.^
開心學習,學習很開心

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
253  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-11-22 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
9#
發表於 2011-6-5 22:09 | 只看該作者
回復 8# linsurvey2005

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

TOP

linsurvey2005

帖子
84 
主題
15 
精華
0 
積分
123 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2010 
閱讀權限
20 
性別
男 
來自
台南市 
註冊時間
2011-5-16 
最後登錄
2022-9-17 
8#
發表於 2011-6-5 20:21 | 只看該作者
老師可以再指導一下嘛?
好期待內
開心學習,學習很開心

TOP

linsurvey2005

帖子
84 
主題
15 
精華
0 
積分
123 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2010 
閱讀權限
20 
性別
男 
來自
台南市 
註冊時間
2011-5-16 
最後登錄
2022-9-17 
7#
發表於 2011-6-4 23:32 | 只看該作者
感謝老師不吝指導,它山之法
我再次增加了開檔行列
繼續選取資料就顯示到選取的活頁簿
如果結束選取就顯示到新的活頁簿
因巨集是在另外一個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  
.........
.......
....
開心學習,學習很開心

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
253  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-11-22 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
6#
發表於 2011-6-4 16:24 | 只看該作者
當新的活頁簿開啟時，作用中活頁簿會指向該新增的活頁簿
ThisWorkbook.Activate
確保作用中活頁簿會是程式碼所在之活頁簿
此時新活頁簿仍然是顯示的，只是顯示在下一層視窗

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

TOP

linsurvey2005

帖子
84 
主題
15 
精華
0 
積分
123 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2010 
閱讀權限
20 
性別
男 
來自
台南市 
註冊時間
2011-5-16 
最後登錄
2022-9-17 
5#
發表於 2011-6-4 15:08 | 只看該作者
感謝老師的再三回覆
請教以下幾行是不是讓物件由"K"畫面(顯示狀態)帶出資料後
插入新活頁簿(隱藏狀態),這樣是提高作業效率的一種嗎?
另外對"K"物件釋放,是不是防止資料多 電腦會卡卡的.
不好意思問題比山高~^.^
Set Wb = Workbooks.Add    '開啟新活頁簿
ThisWorkbook.Activate
k.Copy Wb.ActiveSheet.[A3]
Set k = Nothing
開心學習,學習很開心

TOP

        靜思自在 : 能善用時間的人，必能掌握自己努力的方向。
123
返回列表 上一主題