求助建立迴圈應用 - Excel程式區

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

中學生 Rank: 2

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

中學生 Rank: 2

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

超級版主 Rank: 8 Rank: 8

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

2025年全勤獎章 2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

11^#

發表於 2011-6-6 11:06 | 只看該作者

回復 10# linsurvey2005

試試看這樣是不是你要的

Sub Selection_Copy()
Dim fs$, SRng, SourceWb As Workbook
fs = Application.GetOpenFilename("Excel 檔案(*.xls),*.xls")
Set SourceWb = Workbooks.Open(fs)
k = Application.InputBox("請選取欲複製的範圍", , , , , , , 8)
If TypeName(k) = "Boolean" Then SourceWb.Close 0: Exit Sub
Set nwb = Workbooks.Add
With nwb.Sheets(1)
.Activate
r = Application.Max(12, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
If IsArray(k) Then
.Cells(r, 1).Resize(UBound(k, 1), UBound(k, 2)) = k
Else
.Cells(r, 1) = k
End If
yn = MsgBox("是否繼續", vbYesNo): GoTo 10
Do Until yn <> 6 Or TypeName(k) = "Boolean"
r = Application.Max(12, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
If IsArray(k) Then
.Cells(r, 1).Resize(UBound(k, 1), UBound(k, 2)) = k
Else
.Cells(r, 1) = k
End If
yn = MsgBox("是否繼續", vbYesNo)
10
If yn = 6 Then SourceWb.Activate: k = Application.InputBox("請選取欲複製的範圍", , , , , , , 8)
Loop
nwb.Activate
DoEvents
myfilename = Format(Date, "yymmdd") & "-Tilt-PDA.xls"
Application.SendKeys myfilename, True
sf = Application.GetSaveAsFilename("E:\")
If sf <> False Then nwb.SaveAs sf
SourceWb.Close 0
End With
End Sub

複製代碼

學海無涯_不恥下問

TOP

linsurvey2005

中學生 Rank: 2

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

超級版主 Rank: 8 Rank: 8

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

2025年全勤獎章 2024年全勤獎章 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

中學生 Rank: 2

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

8^#

發表於 2011-6-5 20:21 | 只看該作者

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

開心學習,學習很開心

TOP

linsurvey2005

中學生 Rank: 2

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

超級版主 Rank: 8 Rank: 8

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

2025年全勤獎章 2024年全勤獎章 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

中學生 Rank: 2

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

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

[收藏此主題] [關注此主題的新回復]

[通過 QQ、MSN 分享給朋友]