Code is writing over instead of appending

[Brutusar]

Hi, I have a workbook with a number of sheets where many rows has no value in column A, but have values in other columns. What the code needs to do is to do is this:

• Loop thru all rows in all sheets
• If a row has no value in column A, copy and append the row to a sheet called "Note", starting in cell A1

I have written a code meant to do this but in stead of appending the rows, the values are being overwritten in the same cells all the time, so no appending is going on.

My code is below, can somebody have a look and maybe point me in the right direction of what I have done wrong?

Sub CopyEmptyRowsToNoteSheet()

    Dim ws As Worksheet
    Dim noteSheet As Worksheet
    Dim lastRow As Long
    Dim i As Long
    
    Set noteSheet = ThisWorkbook.Sheets("Note")
    
    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> "Note" Then
            lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            
            For i = 1 To lastRow
                If ws.Cells(i, "A").Value = "" Then
                    ws.Cells(i, "A").EntireRow.Copy noteSheet.Cells(noteSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1, "A")
                End If
            Next i
        End If
    Next ws
End Sub

 

[Joe4]

I think you may need to update this line:

ws.Cells(i, "A").EntireRow.Copy noteSheet.Cells(noteSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1, "A")

to this:

ws.Cells(i, "A").EntireRow.Copy noteSheet.Cells(noteSheet.Cells(noteSheet.Rows.Count, "A").End(xlUp).Row + 1, "A")

 

[mumps]

Try:

Sub CopyEmptyRowsToNoteSheet()
    Application.ScreenUpdating = False
    Dim ws As Worksheet, noteSheet As Worksheet, lastRow As Long, i As Long, x As Long: x = 1
    Set noteSheet = ThisWorkbook.Sheets("Note")
    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> "Note" Then
            lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            For i = 1 To lastRow
                If ws.Cells(i, "A").Value = "" Then
                    ws.Cells(i, "A").EntireRow.Copy noteSheet.Range("A" & x)
                    x = x + 1
                End If
            Next i
        End If
    Next ws
    Application.ScreenUpdating = False
End Sub

 

[Brutusar]

I think you may need to update this line:

ws.Cells(i, "A").EntireRow.Copy noteSheet.Cells(noteSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1, "A")

to this:

ws.Cells(i, "A").EntireRow.Copy noteSheet.Cells(noteSheet.Cells(noteSheet.Rows.Count, "A").End(xlUp).Row + 1, "A")

Great, thanks!

 

[Brutusar]

Try:

Sub CopyEmptyRowsToNoteSheet()
    Application.ScreenUpdating = False
    Dim ws As Worksheet, noteSheet As Worksheet, lastRow As Long, i As Long, x As Long: x = 1
    Set noteSheet = ThisWorkbook.Sheets("Note")
    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> "Note" Then
            lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            For i = 1 To lastRow
                If ws.Cells(i, "A").Value = "" Then
                    ws.Cells(i, "A").EntireRow.Copy noteSheet.Range("A" & x)
                    x = x + 1
                End If
            Next i
        End If
    Next ws
    Application.ScreenUpdating = False
End Sub

Working perfect, thanks!

 

[mumps]

You are very welcome.