エクセルVBAで手差しトレイを指定させる方法
- エクセルVBAを使用して、手差しトレイを指定する方法について教えてください。
- 特定のプリンターを指定せず、ユーザーにトレイを選択してもらうためのVBAコードを教えてください。
- エクセル2010で、Print用シートを連続して印刷する際に、特殊な台紙を手差しトレイに入れる方法を教えてください。
- ベストアンサー
エクセルVBAで手差しトレイを指定させたい。
エクセル2010です。 だいぶ端折ってますが、以下のようなコードでDATAシートのデータをInput用シートに転記し、それを参照しているPrint用シートを連続して印刷したいのです。 その歳、印字する用紙はA4等の定形サイズではない特殊な台紙なので、プリンターで「手差し」トレイに入れます。 自分の端末だとプリンターは決まっているので指定できると思うのですが、このエクセルを使う人が特定できず、どのようなプリンターなのかわかりません。（少なくとも手差しトレイはあります） そのためPrint実行前にユーザーにトレイを選択してもらうにはどのようなコードを書き加えればよいでしょうか？ご教示いただければ幸いです。 Sub test01() Dim ws(2) As Worksheet Dim i As Long, x As Long Set ws(0) = Sheets("DATA") Set ws(1) = Sheets("Input用") Set ws(2) = Sheets("Print用") x = ws(0).Cells(Rows.Count, "A").End(xlUp).Row For i = 1 To x - 1 ws(1).Range("A1:N1").Value = ws(0).Range("A1:N1").Offset(i).Value ws(2).PrintOut Next End Sub
- emaxemax
- お礼率100% (834/834)
- Excel（エクセル）
- 回答数1
- ありがとう数2
- みんなの回答 （1）
- 専門家の回答
質問者が選んだベストアンサー
こんにちは。 「プリンターの設定」ダイアログを使うのはどうでしょうか? Application.Dialogs(xlDialogPrinterSetup).Show これで使えます。
関連するQ&A
- ExcelのVBAについて(勉強中のです。)
ExcelのVBAについて(勉強中のです。) ここからコード3以降に入力したコードを抜き出してデータ表を作成しそれを保存するコードを作成したいです。例えばCSV形式にするとか？ データ表は1日分の表示で、保存して週間や月間または統計データまでを視野にいれています。今回は保存する所です。。 利用しやすい状態と保存形式で、よろしくお願いします。データは生活記録みたいなものです。何したどうしたどうなった？ ※大分分岐する予定で、作成中であり、今回はコードの整理は不要です。 '///Sheet1/// Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim time7 As Range For Each time7 In Target If time7.Column = 1 Then time7.Offset(0, 4).Value = Format(Now, "Short Time") & vbCrLf & _ Format(Now, "yyyy/mm/dd hh:nn:ss AM/PM") End If Application.EnableEvents = False Application.EnableEvents = True Next time7 '(1)シートを変数にセット Dim ws1 As Worksheet Dim ws2 As Worksheet Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") '(2)シートを指定してデータを転記 ws2.Range("A3:H3").Value = ws1.Range("A3:H3 ").Value End Sub Private Sub Worksheet_Activate() ' ' 新規行挿入 ' ' Worksheets("Sheet2").Range("3:3").Insert Sheets("Sheet1").Range("H3").Select ActiveCell.FormulaR1C1 = "5" Sheets("Sheet1").Range("E3").Select Selection.ClearContents Dim str_Left As String 'セルE4に文字列、セルH4に数字を予め入れておくこと。 str_Left = Left(Cells(4, 5), Cells(4, 8)) MsgBox str_Left & vbCrLf & " " & "OKボタンを押してください!" Sheets("Sheet1").Range("A3").Select Dim se_r As String se_r = Application.InputBox("バーコードを入力してください") Select Case se_r Case "False" MsgBox "キャンセルされました" Case "" MsgBox "空欄が入力されました" Case Else Range("A3").Value = se_r End Select End Sub ' ///Sheet2/// Private Sub Worksheet_Activate() Dim Emp(1 To 300) As String Dim msg As String Dim i, i2, Cnt As Integer Dim N_In As Variant For i = 3 To 3 If IsEmpty(Cells(i, 1).Value) = False Then 'ここで空欄判定 Worksheets("Sheet1").Range("3:3").Insert '対象セルアドレスを改行処理 End If Next i '(1)シートを変数にセット Dim ws1 As Worksheet Dim ws2 As Worksheet Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") ws1.Activate End Sub
- 締切済み
- その他（プログラミング・開発）
- VBA（エクセル）で教えて下さい。開いていないBOOKの貼り付け
VBA（エクセル）で教えて下さい。開いていないBOOKのシートを開いているBOOKのシートに貼り付けで、開いているBOOKから開いていないBOOK名を指定したいのですが、 現在開いているエクセルです。 SHEETS(Type)のRANGE（A1）に閉じているBOOK名を入力します。 SHEETS（In）に閉じているBOOKのSHEETSを貼り付けたいのですが、 Ex = Sheets("Type").Range("A1") が無いと閉じているEx.xlsを貼り付けます。 このExと言うBOOK以外も多々コピーしたいのですが、どのように書けば良いか分からず、 是非、教えて下さい。 Sub a1() Dim wsSrc As Worksheet, WS As Worksheet Dim PasteR As Range Dim x As Long Sheets("In").Select Cells.Select Selection.Delete Shift:=xlUp Range("A1").Select 'If Worksheets(1).Name = "STEP1" Then ' Worksheets(1).Activate ' Cells.ClearContents ' Else 'Worksheets.Add(Before:=Worksheets(1)).Name = "一覧" 'End If Ex = Sheets("Type").Range("A1") Set wsSrc = ActiveSheet Workbooks.Open "C:\WINDOWS\デスクトップ\test\Ex.xls" For Each WS In Worksheets x = WS.Range("A1").CurrentRegion.Rows.Count If WS.Index = 1 Then Set PasteR = wsSrc.Range("A1") Else Set PasteR = wsSrc.Range("A65536").End(xlUp).Offset(1) End If WS.Range(WS.Cells(1, 1), WS.Cells(x, 44)).Copy PasteR Set PasteR = Nothing Next ActiveWorkbook.Close False Set wsSrc = Nothing End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルＶＢＡマクロの質問です。
マクロ初心者です。行き詰まってます。 sheet1には３００件程度のデータがあります。 このデータの３列目の値を、ＶＬＯＯＫＵＰでsheet3のＡ１：Ｂ３０範囲から参照します。そこで取得した回数分、sheet1の各行のデータをsheet2にコピーしたいんです。 そこで、コード文を作ってみましたが、マクロがうまく動きません。 すみませんが、お知恵を貸していただけないでしょうか？ Dim Z as Long Dim L As Long Dim P As Long Dim Kensaku As String Dim M4 As Range Dim PRow As Long Dim i As Long Set M4 =Sheets(“sheet3”).Range(“A1:B30“) L = Sheets(“sheet1”).Range(“A1”).End(xlup).Row For Z = 1 to L-1 Kensaku = Sheets(“sheet1”).Cells(Z+1,3).Value P=Worksheetfunction.Vlookup(Kensaku,M4,2,False) For i = 1 to P Prow=Sheets(“sheet2”).Range("A1").End(xlDown).Row Sheets(“sheet1”).Rows(Z+1).Copy Sheets(“sheet2”).Rows(Prow) Nexti Next Z
- 締切済み
- Visual Basic
- ＶＢＡで検索してコピー
エクセル2003を使っています。 下記のような構文で、あるデータを検索しています。 検索まではできましたが、その検索したデータが入力されている行を選択して別のシートにコピーしたいです。 Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet Dim rng As Range Set ws1 = Sheets("CSV") '検索先のシート Set ws2 = Sheets("0群加工") '検索データのシート Set ws3 = Sheets("完了") '貼付先シート Set ws4 = Sheets("過程") With ws1.Columns("A") '完全一致でシートの頭から検索（A列） i = 2 Do Until ws2.Cells(i, "E").Value = "" 'ws2のデータがなくなるまで Set rng = .Find(What:=ws2.Cells(i, "E").Value, LookAt:=xlPart, After:=.Cells(.Cells.Count)) '検索 上記は0群加工シートに入力されているデータを、CSVシートに入力されているデータを検索しています。 （ここのデータというのは時間が入力されています。つまり、0群シートに入力されている時間と同じ時間を、CSVシートで検索しています） CSVシートに同じデータがあれば、そのデータがあるセルが属する行をコピーして、違うシートに貼り付けたいです。 よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- エクセルVBAでファイル作成
エクセルVBAで、データをフィルタで抽出し、別なBOOKの指定シートに転記し、名前をつけて保存したいのです。一応、下記のコードでテストは成功しました。 しかし下記コードでは1回ごとにデータの転記先を開かなくてはなりません。 処理する件数が多いので、できればいちいち新たに開き直さなくともよい方法はないでしょうか？ 最初から開いておいて、転記後名前をつけて保存すると、開いていたファイルが閉じてしまい、うまくいきません。 別BOOKでなく別シートに転記して、そのシートをMoveして別ファイル保存ならわかるのですが、今回はどうしても別BOOKに転記しなければなりません。 よろしくお願いします。 Option Explicit Sub データ分割転記() Dim myPth As String, fname As String Dim myRng As Range, myC As Range Dim i As Long, x As Long Dim wb(2) As Workbook Dim ws As Worksheet Dim t As Single t = Timer Set wb(0) = ThisWorkbook myPth = wb(0).Path With wb(0).Sheets("Key") Set myRng = .Range("A2", .Range("A2").End(xlDown)) 'KeyData End With For Each myC In myRng Application.EnableEvents = False Set wb(1) = Workbooks.Open(Filename:=myPth & "\20150806TEST.xlsm") Set ws = wb(1).Sheets("List") With wb(0).Sheets("DATA") .Range("A1:J1").AutoFilter Field:=4, Criteria1:=myC.Value .Range("A2", .Range("A2").SpecialCells(xlLastCell)).SpecialCells(xlCellTypeVisible).Copy ws.Range("A9") .ShowAllData End With With ws x = .Cells(Rows.Count, "A").End(xlUp).Row myC.Offset(, 2).Value = x '行数確認 .Range("A9").Value = 1 If x > 9 Then .Range("A9").AutoFill Destination:=.Range("A9:A" & x), Type:=xlFillSeries '連番 End If End With wb(1).SaveAs Filename:=myPth & "\作成ファイル\" & myC.Value & ".xlsm" wb(1).Close (False) Application.EnableEvents = True i = i + 1 Next MsgBox i & "件を完了" _ & vbCrLf & Timer - t & " Sec." End Sub ＊Application.EnableEvents = False を使っているのば別BOOKが持つイベントマクロを作動させないためです。
- ベストアンサー
- Excel（エクセル）
- ExcelのVBAについてです。シート1と2を作成
ExcelのVBAについてです。シート1と2を作成し、シート1にバーコードまたはキーボードで入力します。シート1は入力専用かつ入力した分の早見表で、実際にはシート2に転記仕訳して、シート3以降に表を作成したいです。使い方はシート1に入力またはシート2をタップまたはクリックすると入力(画面)になります。以前の質問の回答を参考に必要最低限に改良しています。パッと見で構いません、何か不具合は見付からないでしょうか？ '///Sheet1/// Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim time7 As Range For Each time7 In Target If time7.Column = 1 Then time7.Offset(0, 4).Value = Format(Now, "Short Time") & vbCrLf & _ Format(Now, "yyyy/mm/dd hh:nn:ss AM/PM") End If Application.EnableEvents = False Application.EnableEvents = True Next time7 '(1)シートを変数にセット Dim ws1 As Worksheet Dim ws2 As Worksheet Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") '(2)シートを指定してデータを転記 ws2.Range("A3:H3").Value = ws1.Range("A3:H3 ").Value End Sub Private Sub Worksheet_Activate() ' ' 新規行挿入 ' ' Worksheets("Sheet2").Range("3:3").Insert Sheets("Sheet1").Range("H3").Select ActiveCell.FormulaR1C1 = "5" Sheets("Sheet1").Range("E3").Select Selection.ClearContents Dim str_Left As String 'セルE4に文字列、セルH4に数字を予め入れておくこと。 str_Left = Left(Cells(4, 5), Cells(4, 8)) MsgBox str_Left & vbCrLf & " " & "OKボタンを押してください!" Sheets("Sheet1").Range("A3").Select Dim se_r As String se_r = Application.InputBox("バーコードを入力してください") Select Case se_r Case "False" MsgBox "キャンセルされました" Case "" MsgBox "空欄が入力されました" Case Else Range("A3").Value = se_r End Select End Sub ' ///Sheet2/// Private Sub Worksheet_Activate() Dim Emp(1 To 300) As String Dim msg As String Dim i, i2, Cnt As Integer Dim N_In As Variant For i = 3 To 3 If IsEmpty(Cells(i, 1).Value) = False Then 'ここで空欄判定 Worksheets("Sheet1").Range("3:3").Insert '対象セルアドレスを改行処理 End If '(1)シートを変数にセット Dim ws1 As Worksheet Dim ws2 As Worksheet Dim st1, s, i3 As Long Dim Bst As Range Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") '(2)シートを指定してデータを転記 st1 = ws1.Cells(Rows.Count, "E").End(xlUp).Row 'A列の最終行を設定する s = 3 For i3 = 3 To st1 Set Bst = ws2.Columns("E").Find(What:=ws1.Cells(i3, "E"), LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) シート間のE列を比較 If Bst Is Nothing Then '比較して無い場合は、下記を実行 ws1.Cells(s, "A") = ws1.Cells(i3, "A") '追加する文字を転記する。（コード） s = s + 1 End If Next i3 Next i '(1)シートを変数にセット Dim ws1_ As Worksheet Set ws1_ = Worksheets("Sheet1") ws1_.Activate End Sub
- ベストアンサー
- その他（プログラミング・開発）
- エクセル マクロの設定方法について
差込印刷でSheet1に作成した名簿データにより、sheet2に作成しているデータへ差込印刷をしています。現在、次のようなマクロを組んで名簿の件数に合わせて、For ＝ 2 To 500 Step 8を修正しながら、印刷しています。できたら、名簿の件数の増減に関係なく印刷できるようになればと考えています。始めたばかりのマクロ初心者です。よろしくご教授ください。お願いします。 Dim i As Long Dim ws1 As Worksheet, ws2 As Worksheet Set ws1 ＝ sheets(″sheet1″) Set ws2 ＝ sheets(″sheet2″) For i ＝ 2 To 500 Step 8 ws2 .Range(″A1″).Value ＝ ws1.Cells(i+1,2).Value ws2 .Range(″A7″).Value ＝ ws1.Cells(i+2,2).Value ws2 .Range(″A13″).Value ＝ ws1.Cells(i+3,2).Value ws2 .Range(″A19″).Value ＝ ws1.Cells(i+4,2).Value ws2 .Range(″F1″).Value ＝ ws1.Cells(i+5,2).Value ws2 .Range(″F7″).Value ＝ ws1.Cells(i+6,2).Value ws2 .Range(″F13″).Value ＝ ws1.Cells(i+7,2).Value ws2 .Range(″F19″).Value ＝ ws1.Cells(i+8,2).Value DoEvents ws2.PrintOut Next End Subws2 .Range(″F1″).Value ＝ ws1.Cells(i+5,2).Value ネット等で調べて、上記のようなマクロで作業してます。（マクロの設定方法が間違っているところがあると思いますが？）
- ベストアンサー
- オフィス系ソフト
- VBAエクセルにて開いてないエクセルシートを開いてるシートに所得
お世話になります。 「同じフォルダー内にBOOKが2つ有ります。1つ（AK.xls）を立上げて もう1つの（EX.xls）を立上げずに、EX.xls内のSheet1をコピーして AK.xlsのシート（STEP1）に貼り付けようとしています。」 どうしてもエラーが出てしまいます。 何方か、分かる方教えて下さい。 また記述して戴ければもっと助かります。 エラーは”1004”EX.xlsが見つかりません。と出てしまいます。 Sub ST() Dim wsSrc As Worksheet, WS As Worksheet Dim PasteR As Range Dim x As Long Sheets("STEP1").Select Cells.Select Selection.Delete Shift:=xlUp Range("A1").Select Set wsSrc = ActiveSheet Workbooks.Open "EX.xls" For Each WS In Worksheets x = WS.Range("A1").CurrentRegion.Rows.Count If WS.Index = 1 Then Set PasteR = wsSrc.Range("A1") Else Set PasteR = wsSrc.Range("A65536").End(xlUp).Offset(1) End If WS.Range(WS.Cells(1, 1), WS.Cells(x, 44)).Copy PasteR Set PasteR = Nothing Next ActiveWorkbook.Close False Set wsSrc = Nothing End Sub デバックでは Workbooks.Open "EX.xls"この部分が黄色になります。 是非、回答を宜しくお願い致します。
- ベストアンサー
- オフィス系ソフト
- Excel VBA でVLookUPの質問
教えてください。 Excel VBA でVLookUPを使用したいのですが 毎回シート名も数も変わります。 そのため、検索範囲 のシート名をセル値が取得したいのですが どうすればよいでしょうか？ 検索値 = AシートB列 検索範囲=BシートM列 書出し範囲=AシートU列 下記のコード作成しましたが ws = Worksheets("②価格集計").Range("U2").Value 検索用格納配列(i, 1) = "=VLOOKUP(B" & i + 1 & ",ws!A:M,13,0)" でエラーがでます。 他に方法があれば教えてください。 宜しくお願い致します。 Sub test() Dim 検索値 As Range '検索値 Dim 検索用格納配列 As Variant '検索用格納配列 Dim 出力範囲 As Range '出力範囲 Dim i As Long Dim 検索範囲 As Range Dim endrow As Long Dim ws As Worksheet endrow = Sheets("①SPOT売却明細貼付").Range("B" & Rows.Count).End(xlUp).Row Set 検索値 = Worksheets("②価格集計").Range("B3:B302") Set 出力範囲 = Worksheets("②価格集計").Range("U3:U302") ws = Worksheets("②価格集計").Range("U2").Value 検索範囲 = Worksheets(社名).Range("A:M") 検索用格納配列 = Range(検索値, 出力範囲) For i = 1 To endrow 検索用格納配列(i, 1) = "=VLOOKUP(B" & i + 1 & ",ws!A:M,13,0)" Next 出力範囲 = 検索用格納配列 End Sub
- 締切済み
- Excel（エクセル）
- （VBA)文字列を指定位置から抜き出す
Office2019，Windows10 文字列の指定位置から文字列の最後までを抜き出すコード（文字列（））を作成しました。 現在は、指定文字列位置を指定するのに目で数えて指定しますが 数え間違えが多いのでミスを少なくする方法を検討しました。 以前教えてもらったコード（Nubering3()）が利用したいのですが、 イメージだけでどうしたらいいか分かりません。 イメージとしては、 １）range(A1)の文字列で添付画像のような画像を表示して、 画像の下部に「どこから？ 数値を入力してください」と表示して 抜き出し開始位置の数値を入力する 添付画像のように文字数が多くなると行が長くなるので 40文字毎に改行されて表示させる （改行が難しい場合は、それに代わる方法でもOKです。） ２）数値が入力されれば、最初の画像（のような）は消えて B列に抜き出し結果が表示される。 ---------------------------------------------------------------- Sub Mid文字列() Dim MojiSuu As Single Dim KokoKara As Variant Dim I As Single Dim Nukidashi As String Dim EndRow As Single EndRow = Cells(1, "A").End(xlDown).Row KokoKara = Application.InputBox(prompt:="どこから？ 数値を入力してください", Title:="数値入力", Type:=1) If TypeName(KokoKara) = "Boolean" Then MsgBox "数値以外が入力されたので終了します。" Exit Sub End If For I = 1 To EndRow MojiSuu = Len(Range("A" & I)) Nukidashi = Mid(Range("A" & I), KokoKara, MojiSuu) Range("B" & I) = L Next I End Sub --------------------------------------------------------------- Sub Nubering3() Dim Ws1 As Worksheet, Ws2 As Worksheet Dim i As Long, j As Long, WRow As Long Dim uRows As Range, uRange As Range Set Ws1 = Sheets("DATA") Set Ws2 = Sheets("Number") Set uRows = Ws2.Rows(1) Set uRange = Ws2.Range("A2") 'Numberシートの初期化（全体=数式・文字・書式・コメント全てをクリア） Ws2.Range("A1:XX100").Clear Application.ScreenUpdating = False For i = 2 To Ws1.Cells(Rows.Count, "A").End(xlUp).Row WRow = Ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1 If Ws2.Range("A1").Value = "" And WRow = 2 Then WRow = 1 End If Set uRows = Union(uRows, Ws2.Rows(WRow)) For j = 1 To Len(Ws1.Cells(i, "A").Value) Ws2.Cells(WRow, j).Value = j Ws2.Cells(WRow + 1, j).Value = Mid(Ws1.Cells(i, "A").Value, j, 1) Set uRange = Union(uRange, Ws2.Cells(WRow + 1, j)) Next Next i 'Numeling 大文字、中央揃え uRows.HorizontalAlignment = xlCenter uRows.Font.Bold = True '分割文字中央揃え罫線外枠 uRange.HorizontalAlignment = xlCenter uRange.Borders.LineStyle = xlContinuous 'セル幅を見やすく Ws2.Range("A1:xx100").ColumnWidth = 3 Application.ScreenUpdating = True Ws2.Activate Set Ws1 = Nothing Set Ws2 = Nothing Set uRows = Nothing Set uRange = Nothing End Sub
- ベストアンサー
- Excel（エクセル）
お礼
なるほど、組み込みダイアログを使えばいいわけですね。 いま、試せる環境がありません。 明日やってみます。 ありがとうございました。
補足
昨日、会社でやったところ無事できました。 ありがとうございました。