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 時間: 2011-6-4 00:53
Sub test()
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
Do Until Err.Number <> 0
Set k = Application.InputBox(myStr, Type:=8) 'data範圍
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 時間: 2011-6-4 11:50
本帖最後由 Hsieh 於 2011-6-4 11:53 編輯
Sub test()
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
Set k = Application.InputBox(myStr, Type:=8) 'data範圍
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
拍謝~我的問題邏輯結構不夠具體造成"腦袋打結"~^.^
還是我給老師看全部的程式碼 這樣比較不會筆誤~^.^
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.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
以上 麻煩老師幫我指正~學無止盡,養生平性~^.^作者: Hsieh 時間: 2011-6-6 11:06
") = Columns("n