[[20230629193801]]　『列の幅と行の高さ』（パン粉）　ページの最後に飛ぶ

『列の幅と行の高さ』（パン粉）

送付状という文字が含まれるシートだけを抽出して、それぞれそのシート名で新しいブックを保存しようと思いました。

元のブックに入っている数式などは値に変換せずそのままに
新しく作られたブックはすべて値変換することができました。
また、セルの色や罫線なども新しいブックにはコピーできたのですが、、
列の幅と行の高さだけが、コピーされません。

なぜでしょうか。

Sub SplitSheets()

    Dim i As Integer
    Dim wb1 As Workbook, wb2 As Workbook
    Dim Cnt As Integer
    Dim CopyFileName As String
    Dim SaveFolderPath As String

    ' 保存先フォルダのパスを設定
    SaveFolderPath = "C:\Users\ユーザー名\Desktop" ' 保存先フォルダのパスを指定

    ' １）シート数の取得
    Set wb1 = ActiveWorkbook
    Cnt = wb1.Sheets.Count

    ' EX）処理が止まらないようにダイヤログを抑制
    Application.DisplayAlerts = False

    For i = 1 To Cnt
        ' シート名に特定の文字列が含まれている場合のみ処理を行う
        If InStr(1, wb1.Worksheets(i).Name, "送付状") > 0 Then
            ' ２）シート名でブックを作成
            CopyFileName = SaveFolderPath & "\" & wb1.Worksheets(i).Name & ".xlsx"
            Workbooks.Add.SaveAs fileName:=CopyFileName

            ' ３）元のブックのシートを先ほど作ったシート名のブックにコピー（値と書式を保持）
            Set wb2 = Workbooks.Open(CopyFileName)
            With wb1.Worksheets(i)
                ' シートの数式や関数を値に変換
                .UsedRange.Value = .UsedRange.Value

                ' シートの書式設定を保持
                .UsedRange.Copy Destination:=wb2.Worksheets(1).Range("A1")

                ' 行の高さをコピー（空白セルも含む）
                .UsedRange.Rows.RowHeight = .UsedRange.Rows.RowHeight

                ' 列の幅をコピー（空白セルも含む）
                .UsedRange.Columns.ColumnWidth = .UsedRange.Columns.ColumnWidth
            End With

            wb2.Worksheets(1).Name = wb1.Worksheets(i).Name

            ' "Sheet1" のワークシートが存在する場合のみ削除する
            If wb2.Worksheets.Count > 1 Then
                wb2.Worksheets("Sheet1").Delete
            End If

            wb2.Close savechanges:=True
        End If
    Next i

    ' EX）抑制したダイヤログ設定もとに戻す
    Application.DisplayAlerts = True
End Sub

＜使用 Excel：Excel2016mac、使用 OS：Windows10 ＞

  With wb1.Worksheets(i)
     ' 行の高さをコピー（空白セルも含む）
     .UsedRange.Rows.RowHeight = .UsedRange.Rows.RowHeight
     ' 列の幅をコピー（空白セルも含む）
     .UsedRange.Columns.ColumnWidth = .UsedRange.Columns.ColumnWidth
 End With
 これって、自分自身を再設定しているだけで変化しないのは当然ですかね。
（xyz） 2023/06/29(木) 20:00:12

元のデータを再設定しているっていうことですか？
ではなぜ、コピーしたほうの関数などがきちんと値で貼り付けになっているのでしょう、、、
教えてください
（パン粉） 2023/06/29(木) 20:05:40

       ' シートの数式や関数を値に変換
       .UsedRange.Value = .UsedRange.Value
       ' シートの書式設定を保持
       .UsedRange.Copy Destination:=wb2.Worksheets(1).Range("A1")
 値に変換してから、wb2にコピーしていますよね。
 コメントが間違っていますけど。
（書式だけ貼り付けなんかしていません。まるごと値も書式もコピーペイストしていますよ。）
 コード自体を落ち着いてよく確認してみてください。
（xyz） 2023/06/29(木) 20:36:13

 sheet1のUsedRangeがA1から始まっている前提を置くと(*)、
 こんなコードになるのではないですか？
 Sub test()
     Dim k&, c&

     With Worksheets(1)
         For k = 1 To .UsedRange.Rows.Count
             Worksheets(2).Rows(k).RowHeight = .Rows(k).RowHeight
         Next
         For c = 1 To .UsedRange.Columns.Count
             Worksheets(2).Columns(c).ColumnWidth = .Columns(c).ColumnWidth
         Next
     End With
 End Sub
 (*) そうでない場合は修正が必要です。
（xyz） 2023/06/29(木) 21:59:12

直しましたできるようになりました。
あたまがこんがらがってしまいすみませんでした。
Sub シート保存マクロ()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim savePath As String
    Dim fileName As String
    Dim destBook As Workbook
    Dim destSheet As Worksheet
    Dim sourceRange As Range
    Dim destRange As Range

    ' 保存先のフォルダパスを指定
    savePath = "C:\Users\Desktop\"  ' フォルダパスを適宜変更

    ' 以下のコードをそのまま使用

    ' "送付状"を含むシートが存在するかチェック
    Dim sheetExists As Boolean
    sheetExists = False
    For Each ws In ThisWorkbook.Sheets
        If InStr(1, ws.Name, "送付状") > 0 Then
            sheetExists = True
            Exit For
        End If
    Next ws

    ' "送付状"を含むシートが存在しない場合、メッセージボックスを表示して終了
    If Not sheetExists Then
        MsgBox "送付状を含むシートが見つかりません。", vbExclamation
        Exit Sub
    End If

    ' "送付状"を含むシートが存在する場合、処理を続行
    For Each ws In ThisWorkbook.Sheets
        If InStr(1, ws.Name, "送付状") > 0 Then
            ' ファイル名を取得
            fileName = ws.Range("AB2").Value

            ' コピー先のブックを作成
            Set destBook = Workbooks.Add
            Set destSheet = destBook.Sheets(1)

            ' コピー元の範囲を取得
            Set sourceRange = ws.UsedRange

            ' コピー先の範囲に値と書式を貼り付け
            With destSheet
                .Range("A1").Resize(sourceRange.Rows.Count, sourceRange.Columns.Count).Value = sourceRange.Value
                sourceRange.Copy
                .Range("A1").PasteSpecial Paste:=xlPasteFormats
            End With

            ' コピー元の列幅と行高さをコピー先に適用
            For Each C In sourceRange.Columns
                destSheet.Columns(C.Column).ColumnWidth = ws.Columns(C.Column).ColumnWidth
            Next C
            For Each r In sourceRange.Rows
                destSheet.Rows(r.Row).RowHeight = ws.Rows(r.Row).RowHeight
            Next r

            ' ファイルを保存
            destBook.SaveAs savePath & fileName & ".xlsx"

            ' コピー先のブックを閉じる
            destBook.Close SaveChanges:=False
        End If
    Next ws

    ' 完了メッセージを表示
    MsgBox "保存が完了しました。", vbInformation
End Sub

（パン粉） 2023/06/30(金) 06:36:41

解決しているのかもしれませんが２点ほど。

■１
「"送付状"を含むシート」が複数ある場合どうしたいのでしょうか？
（現状だと別々のファイルになりますよね）

■２
＞セルの色や罫線なども新しいブックにはコピーできたのですが、、
＞列の幅と行の高さだけが、コピーされません。
そもそも論になりますが、わざわざ新しいブック（シート）を用意して値貼り付けと体裁調整するのではなく、下記のようにシンプルにシートごとコピーしてから値に直した方が簡単であるように思います。

 (1)対象のシートを丸ごと（新規ブックへ）コピーする
 (2)↑の使用セル（Usedrange）をコピーしてそのまま値貼り付けする
 (3)↑を別名で（名前を付けて）保存する）
 (4)↑を閉じる

のように考えるのも有効であるように思います。
コードにするとこんな感じです。

    Sub 研究用()
        Stop 'ブレークポイントの代わり
        Dim ws As Worksheet
        Dim sheetExists As Boolean

        For Each ws In ThisWorkbook.Worksheets
            If InStr(1, ws.Name, "送付状") > 0 Then
                sheetExists = True
                ws.Copy
                With Workbooks(Workbooks.Count)
                    .Worksheets(1).UsedRange.Copy
                    .Worksheets(1).UsedRange.PasteSpecial Paste:=xlPasteValues
                    .SaveAs fileName:="C:\Users\Desktop\" & .Worksheets(1).Range("AB2").Value, _
                                 FileFormat:=xlOpenXMLWorkbook
                    .Close SaveChanges:=False
                End With
            End If
        Next

        If sheetExists = True Then
            MsgBox "保存が完了しました。", vbInformation
        Else
            MsgBox "送付状を含むシートが見つかりません。", vbExclamation
        End If
    End Sub

（もこな２） 2023/06/30(金) 12:05:33

コメント返信：

[ 一覧(最新更新順) ]

[[20230629193801]] 『列の幅と行の高さ』（パン粉） ページの最後に飛ぶ

[[20230629193801]]　『列の幅と行の高さ』（パン粉）　ページの最後に飛ぶ