VBA コピーで書式が一部変わる

Question

ご覧いただきありがとうございます。

book1からbook2へ転記するコードを書いているのですが、
書式が変わる行が一部あり困っています。

添付の写真のように9～18行目のみ書式が変わります。
確認としては
・book1の書式設定は正しい
・コピー前のbook2の書式設定も正しい
・条件付き書式は未設定

正しい書式は19行目以降です。

どのような操作をすればすべて正しい書式にすることが出来るのでしょうか。

ご助言いただければ幸いです。

宜しくお願いいたします。

Sub test()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'定義枠-------------------------------------------------------------------------------------------
    
    Dim i As Long, x As Long, z As Long, g As Long
    
    Dim ws As Worksheet
    Dim 業者名 As String, 業者 As String
    
    Dim wb As Workbook, motowb As Workbook
    Set wb = ThisWorkbook
    
    Dim ws1 As Object, ws2 As Object
    Set ws1 = wb.Worksheets(1)
    Set ws2 = wb.Worksheets(2)
    
    Dim mrow As Integer, row1 As Integer, row2 As Integer, frow As Long, grow As Long, xrow As Long
    
    Dim flg As Boolean
    
  '-----------------------------------------------------------------------------------------------
    
   '業社シートクリア
    For x = 4 To Worksheets.Count
        xrow = wb.Worksheets(x).Cells(Rows.Count, 1).End(xlUp).row
        wb.Worksheets(x).Range(wb.Worksheets(x).Cells(9, 1), wb.Worksheets(x).Cells(xrow + 10, 13)).ClearContents '+10は保険
    Next x
    
    
   '揚重実績値クリア
    frow = wb.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).row
    ws1.Range(ws1.Cells(9, 1), ws1.Cells(frow + 10, 13)).ClearContents
     
     
    '加工前データ呼び出し
    Workbooks.Open wb.Path & "\加工前データ.xlsx"
    Set motowb = ActiveWorkbook


    '揚重実績シート入力
    mrow = motowb.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).row
    ws1.Range(ws1.Cells(9, 1), ws1.Cells(mrow, 12)).Value = motowb.Worksheets(1).Range(motowb.Worksheets(1).Cells(9, 1), motowb.Worksheets(1).Cells(mrow, 13)).Value
    With ws1.Range(ws1.Cells(9, 1), ws1.Cells(mrow + 3, 13))
        .RowHeight = 23.25
        .Borders.LineStyle = True
    End With
            
    With ws1.Cells(mrow + 3, 9)
        .Value = "回数"
        .Offset(0, 1).Formula = "=SUM(J9:J" & (mrow) & " )"
        .Offset(0, 2).Formula = "合計"
        .Offset(0, 3).Formula = "=SUM(L9:L" & (mrow) & " )"
    End With
    
    
    '業者シート振り分け
    For i = 9 To mrow
    業者名 = ws1.Cells(i, 5)
    
        flg = False
        For Each ws In wb.Worksheets
            If ws.name = 業者名 Then
              flg = True
            End If
            Next ws
    
    If flg = True Then
        On Error GoTo myError
            wb.Worksheets(業者名).Activate
            Set ws = wb.Worksheets(業者名)
            row1 = ws.Cells(Rows.Count, 1).End(xlUp).row
            ws.Range(ws.Cells(row1 + 1, 1), ws.Cells(row1 + 1, 12)).Value = ws1.Range(ws1.Cells(i, 1), ws1.Cells(i, 12)).Value
    
    Else

myError:
            wb.Sheets("業者").Copy After:=wb.Sheets(wb.Worksheets.Count)
            ActiveSheet.name = 業者名
            Set ws = Worksheets(業者名)
            row2 = ws.Cells(Rows.Count, 1).End(xlUp).row
            ws.Range("F4").Value = 業者名
            ws.Range(ws.Cells(row2 + 1, 1), ws.Cells(row2 + 1, 12)).Value = ws1.Range(ws1.Cells(i, 1), ws1.Cells(i, 12)).Value
           
End If
    Next
    
    '各業者シート体裁
    For g = 4 To Worksheets.Count
            grow = wb.Worksheets(g).Cells(Rows.Count, 1).End(xlUp).row
            With wb.Worksheets(g).Cells(grow + 1, 9)
                .Value = "回数"
                .Offset(0, 1).Formula = "=SUM(J9:J" & (grow) & " )"
                .Offset(0, 2).Formula = "合計"
                .Offset(0, 3).Formula = "=SUM(L9:L" & (grow) & " )"
            End With
            
            With Worksheets(g).Range(Worksheets(g).Cells(9, 1), Worksheets(g).Cells(grow + 1, 13))
                .RowHeight = 23.25
                .Borders.LineStyle = True
            End With
            
    Next
ws1.Activate

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
    
End Sub

!

Comments

[tatsu99]

提示されているシートのシートどれでしょうか？
揚重実績シート、業者、業者シートのどれでしょうか？

[SSS_]

book1⇒book2の揚重実績シート
とするのですが、正しく表示されないのは揚重実績シートです。

1行ずつ実行すると、実行している傍から書式が勝手に変更されていきます。

[tatsu99]

それは、ソースのどの行ですか？

[SSS_]

以下の★がついている行です。

'揚重実績シート入力
mrow = motowb.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).row
★ws1.Range(ws1.Cells(9, 1), ws1.Cells(mrow, 12)).Value = motowb.Worksheets(1).Range(motowb.Worksheets(1).Cells(9, 1), motowb.Worksheets(1).Cells(mrow, 13)).Value

[SSS_]

ちなみになのですが、このbook内では
揚重実績シート⇒業者シート⇒表紙とこの先転記していくのですが

揚重実績シート⇒業者シート：こちらの転記では崩れたデータ(この質問の内容です)も正しく直されて転記されます。
業者シート⇒表紙：正しかったデータがまた崩れて転記されます。

と謎です。

[tatsu99]

ありがとうございます。その個所をこちらでも、確認してみます。

[tatsu99]

こちらで、実行させましたところ再現しませんでした。（データの全行、同じ書式です）
揚重実績シートの9行目以降から最後（罫線の最後の行）まで、一旦、手動で削除してから、実行すると
どうなりますでしょうか。

[SSS_]

大変ご親切にありがとうございます。
いったん削除後、書式を正しく再設定し直しましたが同様の現象が起きます。

tatsu99様では再現されないとのことですが、私のエクセル自体の設定がおかしいのでしょうか。

[tatsu99]

うーむ。エクセルの設定がおかしいかどうかはともかく、何か、環境が違うとしか、いいようがないです。
（解決に結びつくコメントでなくてごめんなさい）
もう少し、再現できないか、試行錯誤してみます。

[tosi]

一旦行を削除してやられたら如何でしょうか。
'揚重実績シート入力
ws1.Rows("8:100").Delete
この行から1行づつステップを行います。
画面の動きを確認しながら、どの行から書式のずれがでるか特定します。
これで、Excelの不具合化どうかも見えて来るのではないでしょうか。

[radames1000]

Worksheet_SelectionChangeに何か書いてたりしませんか？
Application.EnableEvents = Falseを最初に入れてみてはどうでしょう。
最後にApplication.EnableEvents = Trueを忘れずに。

Answer 1

コードをざっと見た限りでは、Valueを使って転記してますし、シートのクリアも ClearContents で値のみのクリアですので、コード内では書式を変更するような部分はないですね。

・コピー前のbook2の書式設定も正しい

19行目以降と前で書式設定は間違いなく同じになってますか。

Comments

[SSS_]

はい、もう一度確認しましたが白紙の状態では書式が同じになっています。

[SSS_]

ちなみに
この書式が違う状態でもう一度コードを実行すると、19行目以降も正しくない書式へと書き換わります...

[hatena19]

実際のデータがない状態では動作確認しようがないのですが、もし事実なら怪奇現象としか思えませね。

いっそのことコピーしたあとで、VBAで書式設定をしたらどうでしょうか。
ユーザーが勝手に書式を変更するという可能性もあるので、そういう設計にしておくのが確実です。