Find Rows With Incomplete Data

[verticalreflect]

Hello. I’m hoping you can help.

I have limited Excel skills and I’m a total beginner when it comes to building Macros.

I’ve been given a task to complete, described as below:

I have a sheet (second tab in workbook) which comprises of 7 columns.

I’m looking to build a Macro which will run through each of these rows, identifies any rows which have incomplete data (one or more cells within a row are empty), deletes them from this sheet but pastes the entire row into tab four of the workbook (which is formatted in exactly the same way, 7 columns with the same headings.

Apologies if this is poorly explained, but happy to provide any more info required!

Thanks

 

[igold]

Hi verticalreflect- Welcome to the MrExcel Forum.
Assuming that your second tab is named "Sheet2" and your tab 4 is named "Sheet4" (if not change where indicated), does this work for you. The Header row on both sheets is assumed to start in Cell A1.

Sub MoveRows()

    Dim ws2 As Worksheet: Set ws2 = Worksheets("Sheet2")    '**Change Sheet Name here
    Dim ws4 As Worksheet: Set ws4 = Worksheets("Sheet4")    '**Change Sheet Name here
    Dim arr, arr2, r As Long, c As Long, x As Long, ct As Long
    
    Application.ScreenUpdating = False
    ct = 1
    arr = ActiveSheet.UsedRange
    With ws2.UsedRange
        ReDim arr2(1 To .Rows.Count, 1 To .Columns.Count)
        For r = 1 To .Rows.Count
            For c = 1 To .Columns.Count
                If arr(r, c) = "" Then
                    For x = 1 To .Columns.Count
                        arr2(ct, x) = arr(r, x)
                    Next
                    ct = ct + 1
                    arr(r, 1) = ""
                End If
            Next
        Next
    End With
    ws2.Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    ws2.Columns(1).SpecialCells(xlBlanks).EntireRow.Delete
    ws4.Range("A2").Resize(UBound(arr2, 1), UBound(arr2, 2)) = arr2
    Application.ScreenUpdating = True
    
End Sub

 

[verticalreflect]

Hi verticalreflect- Welcome to the MrExcel Forum.
Assuming that your second tab is named "Sheet2" and your tab 4 is named "Sheet4" (if not change where indicated), does this work for you. The Header row on both sheets is assumed to start in Cell A1.

Sub MoveRows()

    Dim ws2 As Worksheet: Set ws2 = Worksheets("Sheet2")    '**Change Sheet Name here
    Dim ws4 As Worksheet: Set ws4 = Worksheets("Sheet4")    '**Change Sheet Name here
    Dim arr, arr2, r As Long, c As Long, x As Long, ct As Long
   
    Application.ScreenUpdating = False
    ct = 1
    arr = ActiveSheet.UsedRange
    With ws2.UsedRange
        ReDim arr2(1 To .Rows.Count, 1 To .Columns.Count)
        For r = 1 To .Rows.Count
            For c = 1 To .Columns.Count
                If arr(r, c) = "" Then
                    For x = 1 To .Columns.Count
                        arr2(ct, x) = arr(r, x)
                    Next
                    ct = ct + 1
                    arr(r, 1) = ""
                End If
            Next
        Next
    End With
    ws2.Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    ws2.Columns(1).SpecialCells(xlBlanks).EntireRow.Delete
    ws4.Range("A2").Resize(UBound(arr2, 1), UBound(arr2, 2)) = arr2
    Application.ScreenUpdating = True
   
End Sub

Thank you, incredible stuff. It works perfectly, I just wish that I could begin to understand how it all works!

There is another thing though and it’s something I didn’t envisage being a problem:

When I click the ‘Macros’ button on the ribbon, and run the macro from there it works as it should.

The task I’ve been set requires me to have the macro triggered by clicking a button on another worksheet. I’ve been able to right-click and assign the macro to the button, however once I do this and click the button I get the below message:

‘Run-time error ‘13’:

Type mismatch’

Is there something I need to do to the code after assigning the macro to the button? The videos I’ve watched show it being as easy as right-clicking, assigning and clicking for the macro to run but I’m getting this error message. Any advice?

 

[igold]

What are the names of the sheets that you are using. More specifically, where I used "Sheet2", what is the actual name of that sheet. Same thing with "Sheet4. Also what sheet is the Button on...

 

[igold]

See if this change helps. Again if you had to change sheet names you will have to do it again...

Sub MoveRows()

    Dim ws2 As Worksheet: Set ws2 = Worksheets("Sheet2")    '**Change Sheet Name here
    Dim ws4 As Worksheet: Set ws4 = Worksheets("Sheet4")    '**Change Sheet Name here
    Dim arr, arr2, r As Long, c As Long, x As Long, ct As Long
    
    Application.ScreenUpdating = False
    ct = 1
    arr = ws2.UsedRange
    With ws2.UsedRange
        ReDim arr2(1 To .Rows.Count, 1 To .Columns.Count)
        For r = 1 To .Rows.Count
            For c = 1 To .Columns.Count
                If arr(r, c) = "" Then
                    For x = 1 To .Columns.Count
                        arr2(ct, x) = arr(r, x)
                    Next
                    ct = ct + 1
                    arr(r, 1) = ""
                End If
            Next
        Next
    End With
    ws2.Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    ws2.Columns(1).SpecialCells(xlBlanks).EntireRow.Delete
    ws4.Range("A2").Resize(UBound(arr2, 1), UBound(arr2, 2)) = arr2
    Application.ScreenUpdating = True
    
End Sub

 

[verticalreflect]

The sheets

What are the names of the sheets that you are using. More specifically, where I used "Sheet2", what is the actual name of that sheet. Same thing with "Sheet4. Also what sheet is the Button on...

are named:

sheet 2 ‘Customer Data’
sheet 4 ‘Incomplete Data’

The button is on sheet 1.

 

[igold]

Se if this helps at all... I have changed the names for you and altered a line in the code.

Sub MoveRows()

    Dim ws2 As Worksheet: Set ws2 = Worksheets("Customer Data")    '**Change Sheet Name here
    Dim ws4 As Worksheet: Set ws4 = Worksheets("Incomplete Data")    '**Change Sheet Name here
    Dim arr, arr2, r As Long, c As Long, x As Long, ct As Long
    
    Application.ScreenUpdating = False
    ct = 1
    arr = ws2.UsedRange
    With ws2.UsedRange
        ReDim arr2(1 To .Rows.Count, 1 To .Columns.Count)
        For r = 1 To .Rows.Count
            For c = 1 To .Columns.Count
                If arr(r, c) = "" Then
                    For x = 1 To .Columns.Count
                        arr2(ct, x) = arr(r, x)
                    Next
                    ct = ct + 1
                    arr(r, 1) = ""
                End If
            Next
        Next
    End With
    ws2.Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    ws2.Columns(1).SpecialCells(xlBlanks).EntireRow.Delete
    ws4.Range("A2").Resize(UBound(arr2, 1), UBound(arr2, 2)) = arr2
    Application.ScreenUpdating = True
    
End Sub