[[20250313160017]]　『コピー挿入が、実行されません』（とも）　ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) |

| 全文検索 | 過去ログ ]

　

『コピー挿入が、実行されません』（とも）

Sub InsertRowsAndCombineWithHighlight()

    Dim wsCombined As Worksheet
    Dim newSheet As Worksheet
    Dim combinedLastRow As Long
    Dim newLastRow As Long
    Dim i As Long
    Dim j As Long
    Dim differences As Boolean
    Dim rngCopy As Range
    Dim diffList As String
    Dim startRow As Long
    Dim cancel As Boolean

    ' まとめシートを「内訳書(統合版)」として設定
    On Error Resume Next
    Set wsCombined = ThisWorkbook.Sheets("内訳書(統合版)")
    On Error GoTo 0

    If wsCombined Is Nothing Then
        MsgBox "まとめシート「内訳書(統合版)」が見つかりません。", vbCritical, "エラー"
        Exit Sub
    End If

    ' 右隣のシートを設定
    On Error Resume Next
    Set newSheet = wsCombined.Next
    On Error GoTo 0

    If newSheet Is Nothing Then
        MsgBox "右隣のシートが見つかりません。", vbCritical, "エラー"
        Exit Sub
    End If

    ' 最終行を取得（K列の最終行を基準にする）
    combinedLastRow = wsCombined.Cells(wsCombined.Rows.Count, "K").End(xlUp).Row
    newLastRow = newSheet.Cells(newSheet.Rows.Count, "K").End(xlUp).Row

    ' 2行ごとに処理（K9 から開始）
    differences = False
    diffList = "違いが見つかった行:" & vbCrLf
    For j = 9 To newLastRow Step 2
        ' K列の値を比較（wsCombinedとnewSheet）
        If wsCombined.Cells(j, "K").Value <> newSheet.Cells(j, "K").Value Or wsCombined.Cells(j, "K").Value = "" Or newSheet.Cells(j, "K").Value = "" Then
            ' B列の値も比較
            If wsCombined.Cells(j - 1, "B").Value <> newSheet.Cells(j - 1, "B").Value Then
                differences = True
                diffList = diffList & "行 " & (j - 1) & " と " & j & vbCrLf
            End If
        End If
    Next j

    ' 違いがある場合、挿入コピーを実行するかどうかを確認するメッセージを表示
    If differences Then
        If MsgBox(diffList & "挿入コピーを実行しますか？", vbYesNo + vbQuestion, "確認") = vbYes Then
            For j = 8 To newLastRow Step 2
                ' 中断ボタンを表示
                cancel = False
                Application.StatusBar = "処理中... 中断するには[Esc]キーを押してください。"
                DoEvents
                If cancel Then Exit Sub

                ' K列の値を比較（wsCombinedとnewSheet）
                If wsCombined.Cells(j, "K").Value <> newSheet.Cells(j, "K").Value Or wsCombined.Cells(j, "K").Value = "" Or newSheet.Cells(j, "K").Value = "" Then
                    ' B列の値も比較
                    If wsCombined.Cells(j - 1, "B").Value <> newSheet.Cells(j - 1, "B").Value Then
                        ' コピー挿入開始行を確認
                        startRow = j
                        ' シートを表示して確認
                        wsCombined.Activate
                        MsgBox "今回は " & startRow - 1 & " 行目から " & startRow & " 行目までをコピー挿入します。"
                        If MsgBox("コピー挿入を開始する行は " & startRow & " です。よろしいですか？", vbYesNo + vbQuestion, "確認") = vbNo Then
                            startRow = InputBox("コピー挿入を開始する行を指定してください:", "行数指定", startRow)
                        End If

                        ' 行全体をコピー（該当行とその一つ手前の行）
                        Set rngCopy = newSheet.Rows(startRow - 1 & ":" & startRow)

                        ' 挿入位置を決定（該当行に挿入）
                        MsgBox "挿入前の行: " & startRow
                        wsCombined.Rows(startRow - 1).Insert Shift:=xlDown
                        rngCopy.Copy wsCombined.Rows(startRow - 1)
                        Application.CutCopyMode = False
                        MsgBox "挿入後の行: " & startRow

                        ' A列に黄色のハッチング（塗りつぶし）を追加
                        wsCombined.Cells(startRow - 1, "A").Resize(2, 1).Interior.Color = RGB(255, 255, 0) ' 黄色

                        ' 挿入後に再度チェックして、重複コピー挿入を防ぐ
                        combinedLastRow = wsCombined.Cells(wsCombined.Rows.Count, "K").End(xlUp).Row
                        For i = startRow + 1 To combinedLastRow Step 2
                            If wsCombined.Cells(i, "K").Value = newSheet.Cells(i, "K").Value And wsCombined.Cells(i - 1, "B").Value = newSheet.Cells(i - 1, "B").Value Then
                                Exit For
                            End If
                        Next i
                    End If
                End If
            Next j
            Application.StatusBar = False
            MsgBox "処理が完了しました", vbInformation
        Else
            MsgBox "処理がキャンセルされました", vbInformation
        End If
    Else
        MsgBox "違いは見つかりませんでした", vbInformation
    End If
End Sub

---

あと、下記のコードともけんかしてしまうようです
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim SearchValue As String
    Dim SheetList As Collection
    Dim Sheet As Worksheet
    Dim FoundCell As Range
    Dim Quantity As Double
    Dim Amount As Double
    Dim i As Long
    Dim 統合最終行 As Long

    ' 統合シートの最終行を取得（Y列を基準にしています）
    統合最終行 = Cells(Rows.Count, "Y").End(xlUp).Row

    ' 転記先シートと検索範囲を指定
    If Not Intersect(Target, Range("Y9:Y" & 統合最終行)) Is Nothing Then
        SearchValue = Target.Value
        Set SheetList = New Collection

        ' 内訳書(第36回)〜内訳書(第1回)の範囲を検索
        For Each Sheet In ThisWorkbook.Sheets
            If Sheet.Name Like "内訳書(第*" And Sheet.Name <> "内訳書(統合版)" Then
                Set FoundCell = Sheet.Columns("K").Find(What:=SearchValue, LookIn:=xlValues, LookAt:=xlWhole)
                If Not FoundCell Is Nothing Then
                    ' 数量と金額を取得
                    Quantity = FoundCell.Offset(0, 1).Value ' L列
                    Amount = FoundCell.Offset(0, 2).Value ' M列
                    If Quantity <> 0 Then
                        ' シート名、数量、金額を追加
                        SheetList.Add Sheet.Name & " 数量：" & Format(Quantity, "#,##0") & " 金額：" & Format(Amount, "#,##0")
                    End If
                End If
            End If
        Next Sheet

        ' シートリストを配列に変換してソート
        If SheetList.Count > 0 Then
            Dim SheetArray() As String
            ReDim SheetArray(1 To SheetList.Count)
            For i = 1 To SheetList.Count
                SheetArray(i) = SheetList(i)
            Next i

            ' シートリストを昇順にソート
            Call SortSheetArray(SheetArray)

            ' 結果を表示
            Dim FoundSheets As String
            For i = LBound(SheetArray) To UBound(SheetArray)
                FoundSheets = FoundSheets & SheetArray(i) & vbCrLf
            Next i
            MsgBox "検索値 '" & SearchValue & "' が見つかったシート：" & vbCrLf & FoundSheets
        Else
            MsgBox "検索値 '" & SearchValue & "' は見つかりませんでした。"
        End If
    End If
End Sub

Private Sub SortSheetArray(ByRef arr() As String)

    Dim i As Integer, j As Integer
    Dim temp As String
    For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            ' シート名から番号部分を抽出して比較
            If GetSheetNumber(arr(i)) > GetSheetNumber(arr(j)) Then
                temp = arr(i)
                arr(i) = arr(j)
                arr(j) = temp
            End If
        Next j
    Next i
End Sub

Private Function GetSheetNumber(sheetName As String) As Integer

    Dim startPos As Integer, endPos As Integer
    startPos = InStr(sheetName, "第") + 1
    endPos = InStr(sheetName, "回")
    GetSheetNumber = CInt(Mid(sheetName, startPos, endPos - startPos))
End Function

---

あと、一時的に動作したのもあるのですが正しく動作しなかったのでこのコードでご教示願います

＜ 使用 Excel：Microsoft365、使用 OS：Windows11 ＞

---

マジか？
詳しい説明もなしに丸投げ。
その姿勢はいかがなものか？

（苦言） 2025/03/13(木) 16:16:46

---

すいません、突然会議になってしまい投稿だけ急いで登録してしましました

違いを、見つけて違っていたらまとめシートへコピー挿入するコードです。
でも、「完了しました」となるが何も実行されず困っています。
2行１組となっていて2行ずつ転記されてほしいのになぜか２行おきとなってしまいます
（とも） 2025/03/13(木) 17:20:31

---

御自身で書かれたのか、そうでないのかわかりませんが、ざっと見る限りコメントも付けてあって丁寧に作られているとおもいます。

回答者の手元には同じデータはありませんから、まずは御自身で【ブレークポイント】の設定や【ステップ実行】をしてみて問題点を探ってから、「〜という状態」で処理すると、××になるはずが○○になってしまうなど具体的に相談されると回答が付きやすいのではないでしょうか？

また、デバッグ作業をするならさしあたって↓が想定どおりの行を格納できているか、チェックしてみてはどうでしょうか？

 ' 行全体をコピー（該当行とその一つ手前の行）
 Set rngCopy = newSheet.Rows(startRow - 1 & ":" & startRow)

（もこな２ ） 2025/03/14(金) 08:57:55

---

 違いの有無を判定するループは
 For j = 9 To newLastRow Step 2

 コピーするループは
 For j = 8 To newLastRow Step 2

 比較する行は 9行目から始まるのか8行目から始まるのか、どっちなんでしょうか？

 あと関係ないですが、
 SortSheetArray って並べ替えできてます？ 
 ちゃんとバブルソートになってますかね？
（´・ω・`） 2025/03/14(金) 10:35:22

---

Public Sub CheckDifferencesAndHighlight()

    Dim wb As Workbook
    Dim wsCombined As Worksheet
    Dim newSheet As Worksheet
    Dim combinedLastRow As Long
    Dim newLastRow As Long
    Dim j As Long
    Dim differences As Boolean
    Dim diffList As String
    Dim diffCount As Integer
    Dim firstRow As Long
    Dim lastRow As Long
    Dim msg As String
    Dim maxMsgLength As Integer
    Dim tempMsg As String

    ' メッセージボックスの最大文字数（1024文字未満を目安）
    maxMsgLength = 800

    ' アクティブなブックを取得
    Set wb = ThisWorkbook

    ' シートの取得
    On Error Resume Next
    Set wsCombined = wb.Sheets("内訳書(統合版)")
    If wsCombined Is Nothing Then
        MsgBox "まとめシート「内訳書(統合版)」が見つかりません。", vbCritical, "エラー"
        Exit Sub
    End If

    ' 右隣のシートを取得
    Set newSheet = wsCombined.Parent.Sheets(wsCombined.Index + 1)
    If newSheet Is Nothing Then
        MsgBox "右隣のシートが見つかりません。", vbCritical, "エラー"
        Exit Sub
    End If
    On Error GoTo 0

    ' 最終行を取得
    combinedLastRow = wsCombined.Cells(wsCombined.Rows.Count, "K").End(xlUp).Row
    newLastRow = newSheet.Cells(newSheet.Rows.Count, "K").End(xlUp).Row

    ' 比較処理（2行ずつ）
    differences = False
    diffList = ""
    diffCount = 0
    firstRow = 0
    lastRow = 0

    For j = 9 To newLastRow Step 2
        If wsCombined.Cells(j, "K").Value <> newSheet.Cells(j, "K").Value Or _
           wsCombined.Cells(j, "K").Value = "" Or newSheet.Cells(j, "K").Value = "" Then
            If wsCombined.Cells(j - 1, "B").Value <> newSheet.Cells(j - 1, "B").Value Then
                differences = True
                diffCount = diffCount + 1

                ' 連続した範囲をグループ化
                If firstRow = 0 Then
                    firstRow = j
                End If
                lastRow = j + 1
            End If
        Else
            ' 連続範囲が途切れた場合、範囲を確定
            If firstRow <> 0 Then
                diffList = diffList & firstRow & "〜" & lastRow & "行" & vbCrLf
                firstRow = 0
            End If
        End If
    Next j

    ' 最後の範囲を追加
    If firstRow <> 0 Then
        diffList = diffList & firstRow & "〜" & lastRow & "行" & vbCrLf
    End If

    ' メッセージボックスで表示
    If differences Then
        Dim lines As Variant
        Dim i As Integer
        Dim tempLine As String

        ' 改行で分割
        lines = Split(diffList, vbCrLf)
        tempMsg = "違いが見つかりました：" & vbCrLf & vbCrLf

        For i = LBound(lines) To UBound(lines)
            tempLine = lines(i)
            If Len(tempMsg) + Len(tempLine) + 2 > maxMsgLength Then
                ' ここでメッセージボックスを表示
                MsgBox tempMsg, vbInformation, "違いリスト"
                tempMsg = ""
            End If
            tempMsg = tempMsg & tempLine & vbCrLf
        Next i

        ' 残りのメッセージを表示
        If tempMsg <> "" Then
            MsgBox tempMsg, vbInformation, "違いリスト"
        End If

        ' 最後の確認
        If MsgBox("上記の違いを反映してよろしいですか？", vbYesNo + vbQuestion, "確認") = vbYes Then
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual

            For j = 9 To newLastRow Step 2
                If wsCombined.Cells(j, "K").Value <> newSheet.Cells(j, "K").Value Or _
                   wsCombined.Cells(j, "K").Value = "" Or newSheet.Cells(j, "K").Value = "" Then
                    If wsCombined.Cells(j - 1, "B").Value <> newSheet.Cells(j - 1, "B").Value Then
                        Dim startRow As Long
                        Dim rngCopy As Range

                        startRow = j - 1
                        Set rngCopy = newSheet.Rows(startRow & ":" & (startRow + 1))
                        wsCombined.Rows(startRow).Resize(2).Insert Shift:=xlDown
                        rngCopy.Copy
                        wsCombined.Rows(startRow).PasteSpecial Paste:=xlPasteAll
                        Application.CutCopyMode = False
                        wsCombined.Cells(startRow, "A").Resize(2, 1).Interior.Color = RGB(255, 255, 0)
                    End If
                End If
            Next j

            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
            MsgBox "処理が完了しました", vbInformation
        Else
            MsgBox "処理がキャンセルされました", vbInformation
        End If
    Else
        MsgBox "違いは見つかりませんでした", vbInformation
    End If
End Sub
こんな感じは、どうですか
（通勤中の通りすがり） 2025/03/17(月) 12:38:15

---

Sub SearchAndDisplayItems()

    Dim SearchValue As String
    Dim SheetList As Collection
    Dim Sheet As Worksheet
    Dim FoundCell As Range
    Dim Quantity As Double
    Dim Amount As Double
    Dim i As Long
    Dim ResultMsg As String

    ' 検索値を設定 (例: 特定のセルの値を使用)
    SearchValue = InputBox("検索値を入力してください", "検索")

    If SearchValue = "" Then
        MsgBox "検索がキャンセルされました。", vbInformation
        Exit Sub
    End If

    ' シートリストの初期化
    Set SheetList = New Collection

    ' シートをループして検索
    For Each Sheet In ThisWorkbook.Sheets
        If Sheet.Name Like "内訳書(第*" And Sheet.Name <> "内訳書(統合版)" Then
            Set FoundCell = Sheet.Columns("K").Find(What:=SearchValue, LookIn:=xlValues, LookAt:=xlWhole)
            If Not FoundCell Is Nothing Then
                ' 数量と金額を取得
                Quantity = FoundCell.Offset(0, 1).Value ' L列
                Amount = FoundCell.Offset(0, 2).Value ' M列

                ' リストに追加
                If Quantity <> 0 Then
                    SheetList.Add Sheet.Name & " - 数量：" & Format(Quantity, "#,##0") & " - 金額：" & Format(Amount, "#,##0")
                End If
            End If
        End If
    Next Sheet

    ' 結果の表示
    If SheetList.Count > 0 Then
        ResultMsg = "検索値 '" & SearchValue & "' が見つかったシート一覧:" & vbCrLf
        For i = 1 To SheetList.Count
            ResultMsg = ResultMsg & SheetList(i) & vbCrLf
        Next i
        MsgBox ResultMsg, vbInformation
    Else
        MsgBox "検索値 '" & SearchValue & "' は見つかりませんでした。", vbInformation
    End If
End Sub

こっちもてしたね
（通勤中の通りすがり） 2025/03/17(月) 13:57:17

---

Public Sub CheckDifferencesAndHighlight()

    Dim wb As Workbook
    Dim wsCombined As Worksheet
    Dim newSheet As Worksheet
    Dim combinedLastRow As Long
    Dim newLastRow As Long
    Dim j As Long
    Dim differences As Boolean
    Dim diffList As String
    Dim diffCount As Integer
    Dim firstRow As Long
    Dim lastRow As Long
    Dim msg As String
    Dim maxMsgLength As Integer
    Dim tempMsg As String

    ' メッセージボックスの最大文字数（1024文字未満を目安）
    maxMsgLength = 800

    ' アクティブなブックを取得
    Set wb = ThisWorkbook

    ' シートの取得
    On Error Resume Next
    Set wsCombined = wb.Sheets("内訳書(統合版)")
    If wsCombined Is Nothing Then
        MsgBox "まとめシート「内訳書(統合版)」が見つかりません。", vbCritical, "エラー"
        Exit Sub
    End If

    ' 右隣のシートを取得
    Set newSheet = wsCombined.Parent.Sheets(wsCombined.Index + 1)
    If newSheet Is Nothing Then
        MsgBox "右隣のシートが見つかりません。", vbCritical, "エラー"
        Exit Sub
    End If
    On Error GoTo 0

    ' 最終行を取得
    combinedLastRow = wsCombined.Cells(wsCombined.Rows.Count, "K").End(xlUp).Row
    newLastRow = newSheet.Cells(newSheet.Rows.Count, "K").End(xlUp).Row

    ' 比較処理（2行ずつ）
    differences = False
    diffList = ""
    diffCount = 0
    firstRow = 0
    lastRow = 0

    For j = 9 To newLastRow Step 2
        If wsCombined.Cells(j, "K").Value <> newSheet.Cells(j, "K").Value Or _
           wsCombined.Cells(j, "K").Value = "" Or newSheet.Cells(j, "K").Value = "" Then
            If wsCombined.Cells(j - 1, "B").Value <> newSheet.Cells(j - 1, "B").Value Then
                differences = True
                diffCount = diffCount + 1

                ' 連続した範囲をグループ化
                If firstRow = 0 Then
                    firstRow = j
                End If
                lastRow = j + 1
            End If
        Else
            ' 連続範囲が途切れた場合、範囲を確定
            If firstRow <> 0 Then
                diffList = diffList & firstRow & "〜" & lastRow & "行" & vbCrLf
                firstRow = 0
            End If
        End If
    Next j

    ' 最後の範囲を追加
    If firstRow <> 0 Then
        diffList = diffList & firstRow & "〜" & lastRow & "行" & vbCrLf
    End If

    ' メッセージボックスで表示
    If differences Then
        Dim lines As Variant
        Dim i As Integer
        Dim tempLine As String

        ' 改行で分割
        lines = Split(diffList, vbCrLf)
        tempMsg = "違いが見つかりました：" & vbCrLf & vbCrLf

        For i = LBound(lines) To UBound(lines)
            tempLine = lines(i)
            If Len(tempMsg) + Len(tempLine) + 2 > maxMsgLength Then
                ' ここでメッセージボックスを表示
                MsgBox tempMsg, vbInformation, "違いリスト"
                tempMsg = ""
            End If
            tempMsg = tempMsg & tempLine & vbCrLf
        Next i

        ' 残りのメッセージを表示
        If tempMsg <> "" Then
            MsgBox tempMsg, vbInformation, "違いリスト"
        End If

        ' 最後の確認
        If MsgBox("上記の違いを反映してよろしいですか？", vbYesNo + vbQuestion, "確認") = vbYes Then
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual

            For j = 9 To newLastRow Step 2
                If wsCombined.Cells(j, "K").Value <> newSheet.Cells(j, "K").Value Or _
                   wsCombined.Cells(j, "K").Value = "" Or newSheet.Cells(j, "K").Value = "" Then
                    If wsCombined.Cells(j - 1, "B").Value <> newSheet.Cells(j - 1, "B").Value Then
                        Dim startRow As Long
                        Dim rngCopy As Range

                        startRow = j - 1
                        Set rngCopy = newSheet.Rows(startRow & ":" & (startRow + 1))
                        wsCombined.Rows(startRow).Resize(2).Insert Shift:=xlDown
                        rngCopy.Copy
                        wsCombined.Rows(startRow).PasteSpecial Paste:=xlPasteAll
                        Application.CutCopyMode = False
                        wsCombined.Cells(startRow, "A").Resize(2, 1).Interior.Color = RGB(255, 255, 0)
                    End If
                End If
            Next j

            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
            MsgBox "処理が完了しました", vbInformation
        Else
            MsgBox "処理がキャンセルされました", vbInformation
        End If
    Else
        MsgBox "違いは見つかりませんでした", vbInformation
    End If
End Sub

Microsoft365のexcelだと動作しないかな？
（通勤中の通りすがり） 2025/03/18(火) 14:39:42

---

通勤中の通りすがり　さま

返信遅くなりました。試してみたのですが動作しませんでした。
とりあえず、ファイルの中にボタンを作成しそこから実行することにしました。
ファイルの中が、ボタンだらけになっていますが。
Microsoft365は、2019とかとは違うんですね。
（とも） 2025/03/19(水) 06:55:08

---

コメント返信：

---

[ 一覧(最新更新順) ]

---

YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.