転記サンプル

Sub 転記()
    Dim LastRow As Long
    Dim i As Long
    
    ' Sheet1の最終行を取得
    LastRow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    
    ' データ転記
    For i = 2 To LastRow ' 1行目はヘッダーとしてスキップ
        ' Sheet1からSheet2へ値のみ転記
        Sheets("Sheet2").Cells(i, 3).Value = Sheets("Sheet1").Cells(i, 1).Value ' Sheet1のA列からSheet2のC列へ
        Sheets("Sheet2").Cells(i, 5).Value = Sheets("Sheet1").Cells(i, 2).Value ' Sheet1のB列からSheet2のE列へ
        Sheets("Sheet2").Cells(i, 6).Value = Sheets("Sheet1").Cells(i, 3).Value ' Sheet1のC列からSheet2のF列へ
        Sheets("Sheet2").Cells(i, 7).Value = Sheets("Sheet1").Cells(i, 4).Value ' Sheet1のD列からSheet2のG列へ
        Sheets("Sheet2").Cells(i, 8).Value = Sheets("Sheet1").Cells(i, 5).Value ' Sheet1のE列からSheet2のH列へ
        Sheets("Sheet2").Cells(i, 15).Value = Sheets("Sheet1").Cells(i, 6).Value ' Sheet1のF列からSheet2のO列へ
        Sheets("Sheet2").Cells(i, 52).Value = Sheets("Sheet1").Cells(i, 7).Value ' Sheet1のG列からSheet2のAZ列へ
        ' Sheet1のセルO2の日付をYYYY/MM/DD形式の文字列に変換して転記
        Sheets("Sheet2").Cells(i, 13).Value = Format(Sheets("Sheet1").Cells(2, 15).Value, "YYYY/MM/DD")
        Sheets("Sheet2").Cells(i, 18).Value = Sheets("Sheet1").Cells(i, 10).Value ' Sheet1のJ列からSheet2のR列へ
    Next i

    ' 書式のクリア
    'Sheets("Sheet2").Cells.NumberFormat = "@"
End Sub

 

作成するピボットテーブルが「現在のピボットテーブルの書式」または「従来のピボットテーブルの書式」のどちらであるかを選択

Sub CreatePivotTableWithPrompt()
    Dim ws As Worksheet
    Dim pt As PivotTable
    Dim pc As PivotCache
    Dim rngData As Range
    Dim rngDest As Range
    Dim response As VbMsgBoxResult

    ' データ範囲を指定します。適切に変更してください。
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set rngData = ws.Range("A1:D100") ' データの範囲を指定

    ' ユーザーに確認メッセージを表示し、選択させます。
    response = MsgBox("どの書式でピボットテーブルを作成しますか？" & vbCrLf & _
                      "現在のピボットテーブルの書式: 「はい」を選択" & vbCrLf & _
                      "従来のピボットテーブルの書式: 「いいえ」を選択", vbYesNoCancel, "書式の選択")

    If response = vbCancel Then Exit Sub ' キャンセルが選択された場合、処理を終了します。

    ' ピボットテーブルを配置する場所を指定します。適切に変更してください。
    Set rngDest = ws.Range("F1")

    ' ピボットキャッシュを作成します。
    Set pc = ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=rngData)

    ' ピボットテーブルを作成します。
    If response = vbYes Then
        ' 現在のピボットテーブルの書式で作成
        Set pt = rngDest.PivotTableWizard(TableDestination:=rngDest, TableName:="PivotTable1", SourceType:=xlDatabase, SourceData:=rngData)
    ElseIf response = vbNo Then
        ' 従来のピボットテーブルの書式で作成
        Set pt = rngDest.PivotTableWizard(TableDestination:=rngDest, TableName:="PivotTable1", SourceType:=xlDatabase, SourceData:=rngData, DefaultVersion:=xlPivotTableVersion10)
    End If

    ' ピボットテーブルのフィールドを配置します。適切に変更してください。
    With pt
        .PivotFields("Field1").Orientation = xlRowField ' 行フィールドに配置
        .PivotFields("Field2").Orientation = xlColumnField ' 列フィールドに配置
        .PivotFields("Field3").Orientation = xlDataField ' データフィールドに配置
    End With
End Sub

従来のピボットテーブルの書式でピボットテーブルを作成

Sub CreatePivotTableWithFormat()
    Dim ws As Worksheet
    Dim pt As PivotTable
    Dim pc As PivotCache
    Dim rngData As Range
    Dim rngDest As Range
    
    ' データ範囲を指定します。適切に変更してください。
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set rngData = ws.Range("A1:D100") ' データの範囲を指定
    
    ' ピボットテーブルを配置する場所を指定します。適切に変更してください。
    Set rngDest = ws.Range("F1")
    
    ' ピボットキャッシュを作成します。
    Set pc = ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=rngData)
    
    ' ピボットテーブルを作成します。
    Set pt = rngDest.PivotTableWizard(TableDestination:=rngDest, TableName:="PivotTable1", SourceType:=xlDatabase, SourceData:=rngData)
    
    ' ピボットテーブルのフィールドを配置します。適切に変更してください。
    With pt
        .PivotFields("Field1").Orientation = xlRowField ' 行フィールドに配置
        .PivotFields("Field2").Orientation = xlColumnField ' 列フィールドに配置
        .PivotFields("Field3").Orientation = xlDataField ' データフィールドに配置
    End With
    
    ' ピボットテーブルの書式設定を適用します。適切に変更してください。
    With pt
        ' ピボットテーブルの書式設定を行います。
        ' 例えば、フォントの変更、罫線の追加、背景色の変更などを行うことができます。
        ' 以下は書式設定の例です。必要に応じて変更してください。
        .TableStyle2 = "PivotStyleLight1" ' 書式を適用
        .RowAxisLayout xlTabularRow ' 行のレイアウトを表形式に変更
    End With
End Sub

Sheet1からSheet2に列AからGのデータをコピーする方法の例

Sub CopyData1()
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim lastRow As Long
    
    ' ソースシート（コピー元のシート）とターゲットシート（コピー先のシート）を設定
    Set sourceSheet = ThisWorkbook.Sheets("Sheet1")
    Set targetSheet = ThisWorkbook.Sheets("Sheet2")
    
    ' ソースシートの最終行を取得
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
    
    ' ソースシートからデータをコピーしてターゲットシートに貼り付け
    sourceSheet.Range("A2:G" & lastRow).Copy targetSheet.Range("A2")
    
    ' コピーが完了したことをメッセージボックスで通知
    MsgBox "Data has been copied successfully.", vbInformation
End Sub

'//転記先が連続した列でない場合

Sub CopyData2()
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim lastRow As Long
    Dim targetColumn As Integer
    
    ' ソースシート（コピー元のシート）とターゲットシート（コピー先のシート）を設定
    Set sourceSheet = ThisWorkbook.Sheets("Sheet1")
    Set targetSheet = ThisWorkbook.Sheets("Sheet2")
    
    ' ソースシートの最終行を取得
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
    
    ' ターゲットシートの開始列を指定
    targetColumn = 1 ' 例：A列から開始
    
    ' ソースシートからデータをコピーしてターゲットシートに貼り付け
    sourceSheet.Range("A2:G" & lastRow).Copy targetSheet.Cells(2, targetColumn)
    
    ' コピーが完了したことをメッセージボックスで通知
    MsgBox "Data has been copied successfully.", vbInformation
End Sub

'//各列の転記先が連続ではなく、指定された列に転記される場合

Sub CopyData2()
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim lastRow As Long
    Dim targetColumn As Integer
    Dim i As Integer
    
    ' ソースシート（コピー元のシート）とターゲットシート（コピー先のシート）を設定
    Set sourceSheet = ThisWorkbook.Sheets("Sheet1")
    Set targetSheet = ThisWorkbook.Sheets("Sheet2")
    
    ' ソースシートの最終行を取得
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
    
    ' ターゲットシートにおける各列の開始位置を設定
    Dim targetColumns() As Variant
    targetColumns = Array("C", "G", "J", "L", "O", "R", "U")
    
    ' ソースシートからデータをコピーしてターゲットシートに貼り付け
    For i = 1 To 7 ' ソースシートの列数
        sourceSheet.Range(sourceSheet.Cells(2, i), sourceSheet.Cells(lastRow, i)).Copy targetSheet.Cells(2, targetColumns(i - 1))
    Next i
    
    ' コピーが完了したことをメッセージボックスで通知
    MsgBox "Data has been copied successfully.", vbInformation
End Sub

'//各列の転記先に特定の値を転記する条件を追加

Sub CopyData()
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim lastRow As Long
    Dim targetColumn As Integer
    Dim i As Integer
    
    ' ソースシート（コピー元のシート）とターゲットシート（コピー先のシート）を設定
    Set sourceSheet = ThisWorkbook.Sheets("Sheet1")
    Set targetSheet = ThisWorkbook.Sheets("Sheet2")
    
    ' ソースシートの最終行を取得
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
    
    ' ターゲットシートにおける各列の開始位置を設定
    Dim targetColumns() As Variant
    targetColumns = Array("C", "G", "J", "L", "O", "R", "U")
    
    ' ソースシートからデータをコピーしてターゲットシートに貼り付け
    For i = 1 To 7 ' ソースシートの列数
        sourceSheet.Range(sourceSheet.Cells(2, i), sourceSheet.Cells(lastRow, i)).Copy targetSheet.Cells(2, targetColumns(i - 1)).Resize(lastRow - 1)
    Next i
    
    ' 追加の条件：特定の値を特定の列に転記
    targetSheet.Range("D2:D" & lastRow).Value = 111
    targetSheet.Range("H2:H" & lastRow).Value = 222
    targetSheet.Range("I2:I" & lastRow).Value = 333
    targetSheet.Range("M2:M" & lastRow).Value = 444
    targetSheet.Range("P2:P" & lastRow).Value = 555
    targetSheet.Range("S2:S" & lastRow).Value = 666
    targetSheet.Range("V2:V" & lastRow).Value = 777
    
    ' コピーが完了したことをメッセージボックスで通知
    MsgBox "Data has been copied successfully.", vbInformation
End Sub

編集結果を転記する A列の7項目ごとの 繰り返し vba

Sub 編集結果を転記する()
'売上見込み編集
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim targetRow As Long
    Dim targetColumn As Long
    Dim sourceColumns As Long
    
        '編集結果シート初期化
    Sheets("編集結果").Select
    Rows("2:2").Select
    Selection.Delete Shift:=xlUp
    
    
    ' データが格納されているシートを設定
    Set sourceSheet = ThisWorkbook.Sheets("Data")
    ' 編集結果を格納するシートを設定
    Set targetSheet = ThisWorkbook.Sheets("編集結果")
    
    ' 最終行を取得
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, 1).End(xlUp).Row
    ' 転記先の最初の行を設定
    targetRow = 2
    ' 転記先の最初の列を設定
    targetColumn = 1
    
    
    ' 編集結果シートの内容をクリア
    targetSheet.Rows("2:" & targetSheet.Rows.Count).ClearContents
    
    ' 商品名2と金額を別シートに転記
    For i = 1 To lastRow Step 7
        ' データが存在する場合のみ処理
        If sourceSheet.Cells(i, 1).Value <> "" And sourceSheet.Cells(i + 1, 1).Value <> "" Then
        
        Dim R As Long 'Dataシートの列　A2～A7　;　7項目ごとの 繰り返し
        For R = 1 To 6
                targetSheet.Cells(targetRow, R).Value = sourceSheet.Cells(i + R, 1).Value
        Next R
                
            targetRow = targetRow + 1 ' 転記先の行を更新
        End If
    Next i

    ' 販売利益の合計を編集結果シートに挿入
    targetSheet.Cells(targetRow, 1).Value = "販売見込みの合計"
    targetSheet.Cells(targetRow, 2).Value = WorksheetFunction.Sum(Range("b2:b" & targetRow))
    Range("A1").Select
End Sub

販売利益データ編集 + ＰＤＦ保存

Option Explicit
Sub sheet初期化()
    Columns("A:H").Select
    Selection.ClearContents
    Range("A1").Select
End Sub

Sub 売上編集結果()
'出品した商品　販売利益データのデータから編集
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim targetRow As Long
    
    '編集結果シート初期化
    Sheets("編集結果.").Select
    Rows("2:2").Select
    Selection.Delete Shift:=xlUp
    
    ' データが格納されているシートを設定
    Set sourceSheet = ThisWorkbook.Sheets("Data.")
    ' 編集結果を格納するシートを設定
    Set targetSheet = ThisWorkbook.Sheets("編集結果.")
    
    ' 最終行を取得
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, 1).End(xlUp).Row
    ' 転記先の最初の行を設定
    targetRow = 2
    
    ' ループを使用して商品名2と金額を別シートに転記
    For i = 1 To lastRow Step 3
        If sourceSheet.Cells(i, 1).Value <> "" And sourceSheet.Cells(i + 1, 1).Value <> "" Then
              
           ' 商品名2を編集結果のシートに転記
            targetSheet.Cells(targetRow, 1).Value = sourceSheet.Cells(i + 1, 1).Value ' 商品名2を転記
        Dim R As Long 'Dataシートの列　A1～H8
        For R = 2 To 9
            targetSheet.Cells(targetRow, R).Value = sourceSheet.Cells(i + 2, R - 1).Value ' 金額を転記
        Next R
    
            targetRow = targetRow + 1 ' 転記先の行を更新
        End If
    Next i
    
    ' 販売利益の合計を編集結果シートに挿入
    targetSheet.Cells(targetRow, 1).Value = "販売利益の合計"
    targetSheet.Cells(targetRow, 7).Value = WorksheetFunction.Sum(Range("G2:G" & targetRow))
    Range("A1").Select
End Sub

Sub PDF保存()
    Dim targetSheet As Worksheet
    Dim pdfFilePath As String
    Dim currentDate As String

    ' 編集結果のシートを設定
    Set targetSheet = ThisWorkbook.Sheets("編集結果.")
    
    ' 現在の日付を取得
    currentDate = Format(Date, "YYYYMMDD") ' 日付フォーマットを設定して取得
    
    ' PDFの保存先ファイルパスを指定（拡張子 .pdf を含む）
    pdfFilePath = "D:\Mercari\Save\メルカリ売上_" & currentDate & ".pdf" ' ファイル名に日付を組み込む
    
    ' 編集結果のシートをPDFに印刷
    targetSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:=pdfFilePath, Quality:=xlQualityStandard
    
    ' メッセージボックスを表示して保存が完了したことを通知
    MsgBox "PDFが保存されました。", vbInformation
End Sub

Excelシート 目次作成

Sub CreateTableOfContents()
    Dim ws As Worksheet
    Dim tocSheet As Worksheet
    Dim rowNum As Integer
    Dim sheetNum As Integer
    
    ' 新しいシートを作成して目次を作成
    Set tocSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    tocSheet.Name = "目次"
    tocSheet.Range("B1").Value = "目次"
    rowNum = 2
    sheetNum = 1
    
    ' 各シートについてループ処理
    For Each ws In ThisWorkbook.Sheets
        ' 目次に追加しないシートをスキップ
        If ws.Name <> tocSheet.Name Then
            ' シートへのリンクを追加
            tocSheet.Hyperlinks.Add Anchor:=tocSheet.Cells(rowNum, 2), Address:="", SubAddress:="'" & ws.Name & "'!A1", TextToDisplay:=ws.Name
            ' 番号を振る
            tocSheet.Cells(rowNum, 1).Value = sheetNum & "."
            rowNum = rowNum + 1
            sheetNum = sheetNum + 1
        End If
    Next ws
    
    ' 目次シートの装飾
    With tocSheet.Range("A2:A" & rowNum - 1)
        .Font.Bold = True
        .Columns(1).AutoFit
    End With
End Sub

■

Option Explicit
Sub 最短納期抽出()
    Dim wsSource As Worksheet
    Dim wsDestination As Worksheet
    Dim lastRowSource As Long
    Dim lastRowDest As Long
    Dim sourceRange As Range
    Dim destRange As Range
    Dim dict As Object
    Dim key As Variant
    Dim rowNum As Long
    
    ' ソースシートとデスティネーションシートを設定
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
    Set wsDestination = ThisWorkbook.Sheets("Sheet2")
    
    ' ソースシートの最終行を取得
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    
    ' デスティネーションシートの最終行を取得
    lastRowDest = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row
    
    ' ソースシートから型番1と型番2をキーにしてデータを抽出
    Set dict = CreateObject("Scripting.Dictionary")
    For rowNum = 2 To lastRowSource ' ヘッダー行をスキップ
        key = wsSource.Cells(rowNum, 1).Value & "|" & wsSource.Cells(rowNum, 2).Value ' 型番1と型番2をキーにする
        If Not dict.exists(key) Then
            dict.Add key, wsSource.Cells(rowNum, 3).Value ' 納期を追加
        End If
    Next rowNum
    
    ' デスティネーションシートに抽出したデータを出力
    Set destRange = wsDestination.Range("A2") ' 出力先のセルを設定
    For Each key In dict.keys
        destRange.Value = Split(key, "|")(0) ' 型番1
        destRange.Offset(0, 1).Value = Split(key, "|")(1) ' 型番2
        destRange.Offset(0, 2).Value = dict(key) ' 納期
        Set destRange = destRange.Offset(1, 0) ' 次の行へ移動
    Next key
End Sub
Sub 後工程の最短納期抽出2()
    Dim wsSource As Worksheet
    Dim wsDestination As Worksheet
    Dim lastRowSource As Long
    Dim lastRowDest As Long
    Dim sourceRange As Range
    Dim destRange As Range
    Dim dict As Object
    Dim key As Variant
    Dim rowNum As Long
    
    ' ソースシートとデスティネーションシートを設定
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
    Set wsDestination = ThisWorkbook.Sheets("Sheet2")
    
    ' ソースシートの最終行を取得
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    
    ' デスティネーションシートの最終行を取得
    lastRowDest = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row
    
    ' ソースシートから型番1と型番2をキーにしてデータを抽出
    Set dict = CreateObject("Scripting.Dictionary")
    For rowNum = 2 To lastRowSource ' ヘッダー行をスキップ
        key = wsSource.Cells(rowNum, 1).Value & "|" & wsSource.Cells(rowNum, 2).Text & "|" & wsSource.Cells(rowNum, 5).Value ' 型番1、型番2、後工程をキーにする
        If Not dict.exists(key) Then
            dict.Add key, wsSource.Cells(rowNum, 3).Value ' 納期を追加
        End If
    Next rowNum
    
    ' デスティネーションシートに抽出したデータを出力
    Set destRange = wsDestination.Range("A2") ' 出力先のセルを設定
    For Each key In dict.keys
        destRange.Value = Split(key, "|")(0) ' 型番1
        destRange.Offset(0, 1).Value = Split(key, "|")(1) ' 型番2
        destRange.Offset(0, 2).Value = Split(key, "|")(2) ' 後工程
        destRange.Offset(0, 3).Value = dict(key) ' 納期
        Set destRange = destRange.Offset(1, 0) ' 次の行へ移動
    Next key
End Sub

ひな形の隣にシート追加

Sub AddSheetWithDate()
    Dim ws As Worksheet
    Dim newSheet As Worksheet
    Dim templateSheet As Worksheet
    Dim sheetName As String
    Dim templateFound As Boolean
    
    ' 今日の日付をMMDD形式で取得
    sheetName = Format(Date, "mmdd")
    
    ' すでに同じ名前のシートが存在する場合は、終了
    For Each ws In ThisWorkbook.Sheets
        If ws.Name = sheetName Then
            MsgBox "今日の日付のシートはすでに存在します。", vbExclamation
            Exit Sub
        End If
    Next ws
    
    ' 指定したひな形のシートを探す
    templateFound = False
    For Each ws In ThisWorkbook.Sheets
        If ws.Name = "ひな形" Then
            Set templateSheet = ws
            templateFound = True
            Exit For
        End If
    Next ws
    
    ' ひな形が見つからなかった場合はエラーメッセージを表示して終了
    If Not templateFound Then
        MsgBox "指定したひな形のシートが見つかりません。", vbExclamation
        Exit Sub
    End If
    
    ' 新しいシートをひな形の右に追加
    Set newSheet = ThisWorkbook.Sheets.Add(After:=templateSheet)
    
    ' 新しいシートの名前を設定
    newSheet.Name = sheetName
    
    ' 新しいシートに日付を書き込む
    newSheet.Range("A1").Value = "今日の日付: " & Format(Date, "MMDD")
    
    ' 新しいシートをアクティブにする
    newSheet.Activate
End Sub

vbsで Excelvba(.xlsm)起動

Dim FilePath
FilePath = "D:\ThinkpadMark3\自学\filename変更_bat類\.xlsm\繰り返しCopy.xlsm"

Dim app
Set app = CreateObject("Excel.Application")
app.Visible = true
app.Workbooks.Open FilePath
app.Run "Module1.繰り返し"

app.DisplayAlerts = False

app.Workbooks.Open FilePath.save
app.Quit
Set app = Nothing

昨日の日付をセルに出力

Sub 昨日の日付をセルに出力()
    Dim 昨日 As Date
    Dim yyyymmdd As String
    
    ' 昨日の日付を計算
    昨日 = Date - 1
    
    ' yyyymmdd形式で文字列に変換
    yyyymmdd = Format(昨日, "yyyymmdd")
    
    ' セルA1に文字列を出力
    Sheets("sheet1").Range("A1").Value = yyyymmdd
End Sub

Excel形式でファイルを保存/圧縮ファイル作成

Sub ExportToExcelAndCompress()
    Dim xlApp As Object
    Dim xlBook As Object
    Dim rs As Recordset
    Dim strSQL As String
    Dim filePath As String
    
    ' エクスポートするデータのクエリを指定
    strSQL = "SELECT * FROM YourTableName"
    
    ' データをレコードセットとして取得
    Set rs = CurrentDb.OpenRecordset(strSQL)
    
    ' 新しいExcelアプリケーションを開始
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = False ' Excelを表示しないように設定
    
    ' 新しいブックを作成
    Set xlBook = xlApp.Workbooks.Add
    
    ' レコードセットからデータをエクセルにコピー
    rs.MoveFirst
    For i = 0 To rs.Fields.Count - 1
        xlBook.Sheets(1).Cells(1, i + 1).Value = rs.Fields(i).Name
    Next i
    
    Dim rowIndex As Integer
    rowIndex = 2 ' データの書き込みを開始する行
    
    Do Until rs.EOF
        For i = 0 To rs.Fields.Count - 1
            xlBook.Sheets(1).Cells(rowIndex, i + 1).Value = rs.Fields(i).Value
        Next i
        rs.MoveNext
        rowIndex = rowIndex + 1
    Loop
    
    ' Excelファイルを保存
    filePath = "C:\YourFolderPath\YourFileName.xlsx" ' 保存先のファイルパスを指定
    xlBook.SaveAs filePath
    
    ' ブックを閉じる
    xlBook.Close
    
    ' Excelアプリケーションを終了
    xlApp.Quit
    
    ' オブジェクトを解放
    Set xlBook = Nothing
    Set xlApp = Nothing
    rs.Close
    Set rs = Nothing
    
    ' Excelファイルを圧縮する
    Call Shell("powershell.exe -nologo -noprofile -command ""& { Add-Type -Assembly 'System.IO.Compression.FileSystem'; [System.IO.Compression.ZipFile]::CreateFromDirectory('C:\YourFolderPath\', 'C:\YourFolderPath\YourFileName.zip'); }""", vbHide)
    
    ' 元のExcelファイルを削除する（オプション）
    Kill filePath
End Sub

CSV形式でエクスポートし、その後ZIP形式で圧縮

Sub ExportAndCompressData()
    Dim rs As Recordset
    Dim db As Database
    Dim strSQL As String
    Dim exportPath As String
    Dim zipPath As String
    Dim zipFileName As String
    Dim shellApp As Object
    
    ' エクスポートするデータのクエリを指定
    strSQL = "SELECT * FROM YourTableName"
    
    ' エクスポート先のフォルダーとファイル名を指定
    exportPath = "C:\ExportFolder\" ' エクスポート先のフォルダー
    zipFileName = "ExportedData.zip" ' ZIPファイルの名前
    
    ' エクスポート先のフォルダーが存在しない場合、作成する
    If Dir(exportPath, vbDirectory) = "" Then
        MkDir exportPath
    End If
    
    ' データをCSV形式でエクスポート
    DoCmd.TransferText acExportDelim, , "YourTableName", exportPath & "ExportedData.csv"
    
    ' ZIPファイルのパスを設定
    zipPath = exportPath & zipFileName
    
    ' ZIPファイルを作成
    Set shellApp = CreateObject("Shell.Application")
    shellApp.Namespace(zipPath).CopyHere shellApp.Namespace(exportPath & "ExportedData.csv").items
    
    ' エクスポートされたCSVファイルを削除
    Kill exportPath & "ExportedData.csv"
    
    ' オブジェクトを解放
    Set shellApp = Nothing
    
    MsgBox "Data exported and compressed successfully.", vbInformation
End Sub

データをバッチ処理し、複数の小さなファイルに分割するサンプルコード(1,000単位ごと)

Sub ExportDataInBatches()
    Dim rs As Recordset
    Dim db As Database
    Dim strSQL As String
    Dim batchCount As Integer
    Dim batchSize As Integer
    Dim recordCount As Long
    Dim i As Integer
    
    ' バッチサイズとエクスポートするデータの数を設定
    batchSize = 1000 ' 1つのバッチのサイズ
    strSQL = "SELECT * FROM YourTableName" ' エクスポートするデータのクエリを指定
    Set db = CurrentDb
    Set rs = db.OpenRecordset(strSQL)
    recordCount = rs.RecordCount
    
    ' バッチの数を計算
    batchCount = recordCount \ batchSize
    If recordCount Mod batchSize > 0 Then
        batchCount = batchCount + 1
    End If
    
    ' バッチごとにデータをエクスポート
    For i = 1 To batchCount
        rs.MoveFirst
        rs.Move (i - 1) * batchSize
        If i = batchCount Then
            ' 最後のバッチの場合、残りのすべてのレコードをエクスポート
            batchSize = recordCount Mod batchSize
        End If
        ExportBatchToExcel rs, batchSize, i
    Next i
    
    rs.Close
    Set rs = Nothing
    Set db = Nothing
End Sub

Sub ExportBatchToExcel(rs As Recordset, batchSize As Integer, batchNumber As Integer)
    Dim xlApp As Object
    Dim xlBook As Object
    Dim xlSheet As Object
    Dim i As Integer
    Dim j As Integer
    
    ' 新しいExcelアプリケーションを開始
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = False ' Excelを表示しないように設定
    
    ' 新しいブックを作成
    Set xlBook = xlApp.Workbooks.Add
    
    ' レコードセットからデータをエクセルにコピー
    For i = 1 To batchSize
        For j = 0 To rs.Fields.Count - 1
            xlBook.Sheets(1).Cells(i, j + 1).Value = rs.Fields(j).Value
        Next j
        rs.MoveNext
        If rs.EOF Then Exit For
    Next i
    
    ' エクセルファイルを保存
    xlBook.SaveAs "Batch_" & batchNumber & ".xlsx"
    
    ' ブックを閉じる
    xlBook.Close
    
    ' Excelアプリケーションを終了
    xlApp.Quit
    
    ' オブジェクトを解放
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
End Sub

ExcelExport Access

Private Sub ExcelExport()

'変数宣言
Dim filePath As String

'Excelエクスポート先のファイルパス

’filePath = "D:\保存先\" & "Export_" & Format(Date, "yymmdd") & ".xlsx"

' Excelファイルを保存するデスクトップのパスを取得
    filePath = Environ("USERPROFILE") & "\Desktop\" & "Export_" & Format(Date, "yymmdd") & ".xlsx"

'Excelファイルの出力
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "クエリ名", filePath, True, "出力結果"

'Excelファイルをエクスポートした旨を通知する。
MsgBox "Excelをエクスポートしました。"

End Sub