VBA query if top cell is blank.....

[anna82marie]

Hi everyone,

I need help again. I've written a fleet management spreadsheet and I'm having problems with a piece of code that takes filtered information from one sheet and moves it to another.

Code is as below; A3 is header row, if A4 is empty, code bugs out, where it should just be returning "Nothing to Archive"

Where on earth am I going wrong? Management seem to think I know what I'm doing...... I don't.

Sub Move_From_DC_To_Scrapped()

'copy and paste certain columns based on variable in column W

Dim ws1 As Worksheet, ws2 As Worksheet, Lrow As Long, rng As Range

Set ws1 = ThisWorkbook.Sheets("Disposal Criteria")

Set ws2 = ThisWorkbook.Sheets("Archive (Scrapped)")

 Call UnprotectDC

Call UnprotectArchive


 'TurnOff screen updating

    With Application

        .ScreenUpdating = False

        .EnableEvents = False

    End With


Lrow = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row

    With ws1

        .Range("A3").AutoFilter Field:=23, Criteria1:="Y"


    If Range("A3:A" & Lrow).SpecialCells(xlCellTypeVisible).Count > 1 Then
        
       ws1.Range("A4:D" & Lrow).SpecialCells(xlCellTypeVisible).Copy

        ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

 

        ws1.Range("F4:H" & Lrow).SpecialCells(xlCellTypeVisible).Copy

        ws2.Cells(Rows.Count, 1).End(xlUp).Offset(0, 4).PasteSpecial xlPasteValues

             

        ws1.Range("M4:M" & Lrow).SpecialCells(xlCellTypeVisible).Copy

        ws2.Cells(Rows.Count, 1).End(xlUp).Offset(0, 7).PasteSpecial xlPasteValues

         

        ws1.Range("U4:U" & Lrow).SpecialCells(xlCellTypeVisible).Copy

        ws2.Cells(Rows.Count, 1).End(xlUp).Offset(0, 8).PasteSpecial xlPasteValues

        

    Call DeleteRows_DC

    

    Else

                

        ws1.Range("A3").AutoFilter 'clear the filter

    MsgBox "Nothing to Archive"

  
    'TurnOn screen updating

    Application.ScreenUpdating = True

    Application.EnableEvents = True


End If

End With 

Call ProtectDC

Call ProtectArchive

End Sub

 

[Fluff]

If you add this message box as shown, what does it say?

Lrow = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
MsgBox Lrow
    With ws1

 

[anna82marie]

MsgBox Lrow

Hi Fluff,

It says 17 which is where my dummy data was.

 

[anna82marie]

For some reason, if I change

If Range("A3:A" & Lrow).SpecialCells(xlCellTypeVisible).Count > 1 Then​

to

If Range("A" & Lrow).SpecialCells(xlCellTypeVisible).Count > 1 Then​

It seems to work. Just going to run some dummy data and see what happens. I really need to take a VBA course.....

?

​

 

[vcoolio]

Hello Anna,

If you're using the autofilter, we could probably compact your code a little as follows (untested), without worrying about the last row:-

Sub Test()

Application.ScreenUpdating = False

Dim ws1 As Worksheet: Set ws1 = Sheets("Disposal Criteria")
Dim ws2 As Worksheet: Set ws2 = Sheets("Archive (Scrapped)")

UnprotectDC
UnprotectArchive

        With ws1.Range("W3", ws1.Range("W" & ws1.Rows.Count).End(xlUp))
                .AutoFilter 1, "Y"
                Union(.Columns("A:D"), .Columns("F:H"), .Columns("M"), .Columns("U")).Offset(1, -22).Copy
                ws2.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlValues
                '.Offset(1).EntireRow.Delete
                .AutoFilter
        End With
       
ProtectDC
ProtectArchive

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

If you need the relevant rows of data deleted from ws1 after a data transfer is completed, then just remove the apostrophe from in front of this line of code:-

'.Offset(1).EntireRow.Delete

Test it all in a copy of your workbook first.

I hope that this helps.

Cheerio,
vcoolio.