受付簿をNo.を加算しながらループ印刷

１

２コード

'**
'*機能：入力セルに値を増やしながら代入して印刷をループする
'*要確認事項
'*@inputCell(入力セル）
'*@NUM_DIFF(No.の増差)
'*Wait(待機）する秒数
'*
Sub 帳票数字代入印刷マクロ()
    'プリンタ設定確認
    Dim m As String: m = ""
    m = m & "現在のプリンタ設定:" & Application.ActivePrinter & vbNewLine
    m = m & "「片面印刷か両面印刷」は事前に手動保存してください。" & vbNewLine
    m = m & "プリンタ名と片面両面印刷は設定済みとして、印刷を続行してよろしいですか？" & vbNewLine
    If MsgBox(m, vbYesNo, "事前確認") = vbNo Then
        MsgBox "処理を中止します"
        Exit Sub
    End If
    
    '開始No設定
    Dim fromNum As Variant
    fromNum = Application.InputBox( _
        prompt:="開始No.を半角数字で入力してください。", _
        Title:="開始No.入力", _
        Type:=1)
    If fromNum = "False" Then
        MsgBox "処理を中止します"
        Exit Sub
    End If
    
    '印刷枚数設定
    Dim printNum As Variant
    printNum = Application.InputBox( _
        prompt:="何枚分印刷するか、半角数字で入力してください。", _
        Title:="印刷枚数", _
        Type:=1)
    If printNum = "False" Then
        MsgBox "処理を中止します"
        Exit Sub
    End If
    
    '最終確認
    m = ""
    m = m & "プリンタ:" & Application.ActivePrinter & vbNewLine
    m = m & "片面両面設定：あなたが事前確認済" & vbNewLine
    m = m & "印刷開始番号：" & fromNum & vbNewLine
    m = m & "印刷枚数　　：" & printNum & vbNewLine
    m = m & "　以上の内容で印刷してよろしいですか。" & vbNewLine
    If MsgBox(m, vbYesNo, "事前確認") = vbNo Then
        MsgBox "処理を中止します"
        Exit Sub
    End If
    
    '入力セル設定
    Dim inputCell As Range: Set inputCell = Range("A5")
    '印刷1枚目
    inputCell.Value = fromNum
    ActiveSheet.PrintOut Preview:=True
    '印刷2枚目以降
    Dim i As Long
    '注）printNumが1枚のときは何もせずスルーできる
    For i = 2 To printNum
        '印刷に時間かかるので毎回処理を返す
        DoEvents
         '入力する数字に加算する数
        Const NUM_DIFF As Long = 50
        inputCell.Value = inputCell.Value + NUM_DIFF
        ActiveSheet.PrintOut Preview:=True
        '印刷に時間かかるので待つ
        Application.Wait (Now + TimeValue("0:00:05"))
    Next
End Sub

３

背表紙を2枚セットで1ページに印刷その２

１ 選択範囲をintersectでC列に限定しないで、Rows.Rowで掴むことで、無駄なmsgboxを減らした。ただし、１つの列に絞っていないので、同じ行のセルをわざわざCtrを押して離れて選択すると、Rows.rowは重複した行番号を返してしまう。これは無視した。

２コード

Sub 背表紙ラベル印刷_選択バージョン()
    'Sh1:データシート、Sh2:印刷シート
    Dim Sh1 As Worksheet: Set Sh1 = Sheets("Sheet1")
    Dim Sh2 As Worksheet: Set Sh2 = Sheets("Sheet2")
    With Sh1
        '初期化(Sh2はSh1のセルE6:E7を参照している)
        .Range("E6:E7").ClearContents
        '選択範囲の可視セルのうちの、行をtRows(targetRows)に格納
        Dim tRows As Range
        Set tRows = Selection.SpecialCells(xlCellTypeVisible).Rows
        
        '選択を同じ行で離れて（CTRキーを押してクリックして）選択すると
        'tRng.rowが同じ行番号を返してしまうが、そんなことしない前提
        Dim tRng As Range
        For Each tRng In tRows
            '出力用シートに転記済状態のデータ件数
            Dim inputCnt As Long
            Select Case inputCnt
                Case 0
                    .Range("E6").Value = .Range("D" & tRng.Row).Value
                    '1件転記した状態になったから
                    inputCnt = 1
                Case 1
                    .Range("E7").Value = .Range("D" & tRng.Row).Value
                    '2件転記した状態になったから印刷
                    Sh2.PrintOut preview:=True
                    '転記状態を空にする
                    .Range("E6:E7").ClearContents
                    '0件転記された状態になったから
                    inputCnt = 0
                Case Else
                    MsgBox "マクロの記述要確認"
            End Select
        Next
        '最後がぴったり2件埋まらない場合、最後の1件は印刷されていないので印刷
        If inputCnt = 1 Then
            Sh2.PrintOut preview:=True
        End If
    End With
End Sub

３

背表紙を2枚セットで1ページに印刷

1　2レコード単位で処理を繰り返す

cntの数え方を要改善

2

Sub 背表紙2枚セット印刷()
    Dim Sh1 As Worksheet: Set Sh1 = Sheets("Sheet1")
    Dim Sh2 As Worksheet: Set Sh2 = Sheets("Sheet2")
    
    With Sh1
        '初期化
        .Range("E7:E8").ClearContents
        
        'tRng(targetRange)に選択範囲のうちの、C列の可視セルを格納
        Dim tRng As Range
        Set tRng = Selection.SpecialCells(xlCellTypeVisible)
        Set tRng = Intersect(tRng, Columns("C"))
        If tRng = Nothing Then
            MsgBox "C列を選択してください"
            Exit Sub
        End If
        
        Dim tCell As Range
        For Each tCell In tRng
            Dim cnt As Long
            cnt = cnt + 1
            If cnt = 1 Then
                .Range("E7").Value = tCell.Value
            Else
                .Range("E8").Value = tCell.Value
                Sh2.PrintOut preview:=True
                .Range("E7:E8").ClearContents
                cnt = 0
            End If
        Next
        '1レコードだけ余ったときはそれだけで印刷
        If cnt > 0 Then
            Sh2.PrintOut preview:=True
        End If
    End With
End Sub
    

3

シート跨ぎ転記（2シート間転記）マクロ

１　転記元シートから転記先シートへの転記

２　コード

 
Option Explicit


'転記先シートのシートモジュールに記載
'シート跨ぎ転記
Private Sub Worksheet_Activate()
    '転記元シート
    Dim wsFrom As Worksheet: Set wsFrom = Sheets("sheet1")
    With wsFrom
        Dim lastRow As Long
        lastRow = .Range("C" & .Rows.Count).End(xlUp).Row
    End With
    
    'sheet2のシートモジュールに書くので、wsToは省略できる
    Dim wsTo As Worksheet: Set wsTo = Sheets("sheet2")
    With wsTo
        '初期化
        .Rows("11:" & .Rows.Count).ClearContents
        '日付入力
        .Range("F2").Value = Date
        '転記
        .Range("A11:A" & lastRow).Value = wsFrom.Range("A11:A" & lastRow).Value
        .Range("B11:B" & lastRow).Value = wsFrom.Range("B11:B" & lastRow).Value
        .Range("C11:C" & lastRow).Value = wsFrom.Range("C11:C" & lastRow).Value
        .Range("E11:E" & lastRow).Value = wsFrom.Range("D11:D" & lastRow).Value
        .Range("F11:F" & lastRow).Value = wsFrom.Range("E11:E" & lastRow).Value
        .Range("G11:G" & lastRow).Value = wsFrom.Range("F11:F" & lastRow).Value
        .Range("H11:H" & lastRow).Value = wsFrom.Range("G11:G" & lastRow).Value
        .Range("I11:I" & lastRow).Value = wsFrom.Range("H11:H" & lastRow).Value
    End With
End Sub


'転記先シートのシートモジュールに記載
Sub sheet2並べ替え()
'並べ替え
    With ThisWorkbook.Sheets("sheet2")
        .Range("A10").Sort _
                key1:=Range("H10"), order1:=xlAscending, _
                key2:=Range("F10"), order2:=xlAscending, _
                Header:=xlYes
        .Range("A10").Select
    End With
End Sub


'転記先シートのシートモジュールに記載
Sub 指定フォルダへ保存()
    'シートコピー
    '新規シートがアクティブになったとき転記イベントを抑止
    Application.EnableEvents = False
    ThisWorkbook.Sheets("sheet2").Copy
    Application.EnableEvents = True
    '新規ブックを格納
    Dim aWB As Workbook: Set aWB = ActiveWorkbook
    Dim aWS As Worksheet: Set aWS = ActiveSheet

    'パスを格納
    With aWS
        Dim savePath As String: savePath = .Range("K1").Value
        Dim backupPath As String: backupPath = .Range("K2").Value
        Dim saveName As String: saveName = Format(Now, "yyyy-mm-dd-hhmmss_") & .Range("K3").Value
        'パスを書いておいたセルを削除
        .Range("J1:K3").Clear
        .Range("A10").Select
    End With
    
    With aWB
        'xlsx形式で保存
        Application.DisplayAlerts = False
        .SaveAs savePath & "\" & saveName, FileFormat:=xlWorkbookDefault
        .SaveAs backupPath & "\" & saveName, FileFormat:=xlWorkbookDefault
        Application.DisplayAlerts = True
        .Close
    End With
    
    'フォルダを開く
    Shell "Explorer.exe " & savePath, vbNormalFocus
    Shell "Explorer.exe " & backupPath, vbNormalFocus
End Sub



    

オートフィルタで抽出したデータの選択部分を各レコード別に印刷する

１

２

３　コード

    
'**
'*抽出後に、選択したデータでラベルを印刷する
'*
Sub 抽出後に､選択したデータでラベル印刷する()
    'targetRange→tRng
    Dim tRng As Range: tRng = Selection.SpecialCells(xlCellTypeVisible)
    tRng = Intersect(tRng, Columns(1))
    
    'targetCell→tCell
    Dim tCell As Range
    For Each tCell In tRng
        Sheets("転入").Range("D8").Value = tCell.Row - 10
        Sheets("ラベル").PrintOut preview:=True
    Next
End Sub

'**
'*抽出後に、選択したデータでお知らせを印刷する
'*
Sub 抽出後に､選択したデータでお知らせを印刷する()
    'targetRange→tRng
    Dim tRng As Range: tRng = Selection.SpecialCells(xlCellTypeVisible)
    tRng = Intersect(tRng, Columns(1))
    
    'targetCell→tCell
    Dim tCell As Range
    For Each tCell In tRng
        Sheets("転入").Range("D8").Value = tCell.Row - 10
        Sheets("お知らせ").PrintOut preview:=True
    Next
End Sub

４

シートを別ブックに保存する(オフィスTANAKA練習問題４)

1　よく使うコードの整理

2コード

(1)xlsx保存

    Sub TanakaMondai4()
        Dim i As Long
        For i = 2 To Sheets.Count
            ThisWorkbook.Sheets(i).Copy
            With ActiveWorkbook
                .SaveAs "C:\Work\" & ActiveSheet.Name & ".xlsx"
                .Close
            End With
        Next
End Sub

 (2)PDF保存

3疑問 ExportAsFixedFormat でPDFとして保存できるなら、直接ExcelのFormatで別保存できないのか。→答え　できない。

 https://docs.microsoft.com/ja-jp/office/vba/api/excel.workbook.exportasfixedformat

XlFixedFormatType

Can be either xlTypePDF or xlTypeXPS.

4講義

並べ替えて指定フォルダに保存する

１　並べ替えて、保存するマクロ

 　指定の順序で並べ替え。指定のフォルダ（シート内にアドレスを記載）に保存。

２コード

Sub 引継簿並べ替え()
'並べ替え
    With ThisWorkbook.Sheets("引継簿")
        .Range("A5").Sort key1:=Range("G5"), order1:=xlAscending, _
                                    key2:=Range("F5"), order2:=xlAscending, _
                                    Header:=xlYes
        .Range("A5").Select
        '印刷範囲の設定が必要ならする
    End With
End Sub
Sub 引継簿を共有フォルダへ保存()
'シートコピー
    ThisWorkbook.Sheets("引継簿").Copy
    Dim aWB As Workbook: Set aWB = ActiveWorkbook
    Dim aWS As Worksheet: Set aWS = ActiveSheet
'名前を付けて保存
    With aWS
        Dim saveFolderPath As String: saveFolderPath = .Range("K1").Value
        Dim savePath As String: savePath = saveFolderPath & "\" & .Range("K2").Value
'パスの記載を削除
        .Range("J1:L2").ClearContents
'数式を値貼付
        .UsedRange.Value = .UsedRange.Value
        .Range("A5").Select
    End With
    
    With aWB
        .SaveAs savePath
        '閉じる
        .Close
    End With
    'フォルダを開く
    Shell "Explorer.exe " & saveFolderPath, vbNormalFocus
End Sub