0

「N」列に「Complete - Design」を含む「Projects Overview」というシートの行をコピーして別のシートに貼り付けるvbaコードがあります。これはしばらくの間正しく機能していましたが、今では行を複数回貼り付けます。貼り付けられた複製の数が、「プロジェクトの概要」シートで使用されている行の数と一致することがわかりました。コードは各行をループして実行しているだけだと思います。

これが私がこれまでに持っているものです:

Sub CompleteJob()

'Looks through the status column (N) of the Projects Overview table and moves them to Completed table, then deletes row from projects list
Dim Firstrow As Long
Dim lastRow As Long
Dim LrowProjectsOverview As Long

With Sheets("Projects Overview")
    .Select

    Firstrow = .UsedRange.Cells(1).Row
    lastRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
    For LrowProjectsOverview = lastRow To Firstrow Step -1
        With .Cells(LrowProjectsOverview, "N")
            If Not IsError(.Value) Then
                If ((.Value = "Complete - Design") Or (.Value = "P4P") Or (.Value = "Ready for Setup")) Then .EntireRow.Copy Sheet3.Range("A200")

                    If Sheet9.Range("B2").Value = "" Then
                        Sheet9.Range("A2:Q2").Value = Sheet3.Range("A200:Q200").Value
                        Sheet3.Range("A200:Q200").ClearContents

                        Else

                        Sheet9.Range("B2").EntireRow.Insert
                        Sheet9.Range("A2:Q2").Value = Sheet3.Range("A200:Q200").Value
                        Sheet3.Range("A16:Q16").ClearContents
                        Sheet9.Range("B2:Q2").Interior.Color = xlNone
                        Sheet9.Range("B2:Q2").Font.Bold = False
                        Sheet9.Range("B2:Q2").Font.Color = vbBlack
                        Sheet9.Range("B2:Q2").RowHeight = 14.25

                    End If

                    If Sheet9.Range("B2").Value = "" Then
                       Sheet9.Range("B2").EntireRow.Delete

                    End If

                If ((.Value = "Complete - Design") Or (.Value = "P4P") Or (.Value = "Ready for Setup")) Then .EntireRow.Delete

            End If
        End With
    Next LrowProjectsOverview
End With

End Sub
4

0 に答える 0