zipへの追加

Sub Main()

    Dim maxPathIndex As Integer

    maxPathIndex = 10 ' パスの配列の最大値（仮）を表す定数

    

    ' パスの配列を初期化

    Dim paths() As Variant

    ReDim paths(1 To maxPathIndex)

    

    ' パスの配列にファイルパスを設定

    paths(1) = "C:\Users\ichim\ブック.xlsx"

'    paths(2) = "YourPath02"

    

    ' 圧縮されたZIPファイルの保存先としてファイル名を指定

    Dim zipFileName As String

 

    zipFileName = "C:\Users\ichim\ブック11.zip"

 

    Call CompressFilesToZIP(paths, zipFileName)

End Sub

 

 

 

Function CompressFilesToZIP(ByVal paths As Variant, ByVal zipFileName As String)

    ' 圧縮対象のファイルパスとZIPファイル名を定義

    Dim srcFilePath As String

    

    ' パスの配列を連結し、末尾のカンマを除いた文字列を取得

    srcFilePath = ConcatPathsAndRemoveComma(paths)

    

    ' ZIPファイルを作成するサブルーチンを呼び出し

    Call ExecutePowerShellZIPCompression(zipFileName, srcFilePath)

    

End Function

 

Function ConcatPathsAndRemoveComma(ByVal paths As Variant) As String

    ' パスの配列を連結し、末尾のカンマを除いた文字列を返す関数

    Dim result As String

    Dim i As Integer

    Dim maxIndex As Integer

    

    ' パスの配列の最大値を取得

    maxIndex = GetMaxIndex(paths)

 

    ' パスの配列をカンマで連結

    For i = LBound(paths) To maxIndex

        result = result & paths(i) & ","

    Next i

    

    ' 末尾のカンマを除く

    If Right(result, 1) = "," Then

        result = Left(result, Len(result) - 1)

    End If

    

    ' 連結した文字列を返す

    ConcatPathsAndRemoveComma = result

End Function

 

Function ExecutePowerShellZIPCompression(ByVal zipFileName As String, ByVal srcFilePaths As String)

    ' ZIPファイルを作成するサブルーチン

    Dim PowerShellCmd As String

    Dim objWsh As Object

    Dim execResult As Long

    

    ' WScript.Shell オブジェクトを生成

    Set objWsh = CreateObject("WScript.Shell")

   

    ' ファイルパスとZIPファイル名に対して置換処理を実行

    srcFilePaths = ReplaceForPowerShell(srcFilePaths)

    zipFileName = ReplaceForPowerShell(zipFileName)

    

    ' ZIPファイルを作成するためのPowerShellコマンドを生成

    PowerShellCmd = "powershell -NoLogo -ExecutionPolicy RemoteSigned -Command Compress-Archive -Path " & srcFilePaths & " -DestinationPath " & zipFileName & " -Force"

    

    ' ZIPファイルがすでに存在するか確認

    Sheets("Sheet3").Range("G1") = zipFileName

    If Dir(zipFileName) <> "" Then

        ' PowerShellコマンドを実行

        execResult = objWsh.Run(Command:=PowerShellCmd, WindowStyle:=0, WaitOnReturn:=True)

    End If

    

    ' エラーを処理

    If execResult = 1 Then

        Stop ' エラーが発生しました

    Else

        ' エラーは発生しませんでした。

    End If

    

    ' WScript.Shell オブジェクトを解放

    Set objWsh = Nothing

End Function

 

Function ReplaceForPowerShell(ByVal inputString As String) As String

    ' スペースを含む文字列をバッククォートでエスケープ

    ReplaceForPowerShell = Replace(inputString, " ", "` ")

 

    ' 全角スペースを含む文字列をバッククォートでエスケープ

    ReplaceForPowerShell = Replace(ReplaceForPowerShell, "　", "`　")

 

    ' 開きカッコをバッククォートでエスケープ

    ReplaceForPowerShell = Replace(ReplaceForPowerShell, "(", "`(")

 

    ' 閉じカッコをバッククォートでエスケープ

    ReplaceForPowerShell = Replace(ReplaceForPowerShell, ")", "`)")

 

    ' 長音記号（ー）をバッククォートでエスケープ

    ReplaceForPowerShell = Replace(ReplaceForPowerShell, "ー", "`ー")

 

    ' 下線記号（＿）をバッククォートでエスケープ

    ReplaceForPowerShell = Replace(ReplaceForPowerShell, "＿", "`＿")

End Function

 

 

Function GetMaxIndex(ByVal arr As Variant) As Integer

    ' 配列の最大インデックスを取得する関数

    Dim i As Integer

    i = LBound(arr)

    Do While i <= UBound(arr) And Not IsEmpty(arr(i))

        i = i + 1

    Loop

    GetMaxIndex = i - 1

End Function

Sub InsertHorizontalPageBreak()

    Dim ws As Worksheet

    Dim rowNum As Long

    

    ' 対象となるワークシートを設定

    Set ws = ThisWorkbook.Sheets("Sheet1") ' Sheet1を対象に変更してください

    

    ' 改ページを挿入する行番号を設定

    rowNum = 20 ' 例として20行目に挿入

    

    ' 水平な改ページを挿入

    ws.HPageBreaks.Add Before:=ws.Cells(rowNum, 1)

End Sub

 

 

 

Function RowsToFitInOnePage(ws As Worksheet, startRow As Long, endRow As Long) As Long

    Dim pagesWide As Long

    Dim pagesTall As Long

    Dim tempWs As Worksheet

    

    ' 一時的なワークシートを作成

    Set tempWs = ThisWorkbook.Worksheets.Add

    

    ' 指定した範囲を一時的なワークシートにコピー

    ws.Range(ws.Cells(startRow, 1), ws.Cells(endRow, ws.Columns.Count)).Copy Destination:=tempWs.Range("A1")

    

    ' ページ設定を調整

    With tempWs.PageSetup

        .Zoom = False

        .FitToPagesWide = 1

        .FitToPagesTall = 1

    End With

    

    ' ページの高さを取得

    pagesTall = tempWs.HPageBreaks.Count + 1

    

    ' 一時的なワークシートを削除

    Application.DisplayAlerts = False

    tempWs.Delete

    Application.DisplayAlerts = True

    

    ' 1ページに収まる行数を計算

    RowsToFitInOnePage = (endRow - startRow + 1) / pagesTall

End Function

Dim ws5, ws6 As Worksheet

Dim w1, h1 As Double

Dim i As Long

Set ws5 = Sheets("Sheet5")

Set ws6 = Sheets("Sheet6")

For i = 1 To 300

    h1 = ws6.Rows(i).RowHeight

     ws5.Rows(i).RowHeight = h1

Next

For i = 1 To 100

 w1 = ws6.Columns(i).ColumnWidth

   ws5.Columns(i).ColumnWidth = w1

Next

 

Sub GetRGBFromColorPalette()

    Dim colorIndex As Long

    Dim rgbColor As Long

    

    ' カラーパレットから色を選択

    colorIndex = Application.Dialogs(xlDialogEditColor).Show(, , , "Please select a color")

    

    ' カラーコードをRGB値に変換

    rgbColor = ActiveWorkbook.Colors(colorIndex)

    

    ' RGB値を表示

    MsgBox "RGB values: (" & (rgbColor Mod 256) & ", " & ((rgbColor \ 256) Mod 256) & ", " & (rgbColor \ 65536) & ")"

 

End Sub