Auto transferring expired rows to 2nd worksheet

[MrCameronExcel]

Hello,

I am looking for some help creating VBA code that will transfer expired rows from the first worksheet - called "Valid Clearances" - to the second worksheet - called "Expired Clearances"

I initially troubleshooted this issue via google, but the codes I found never worked when I tried to apply them.

Below is a sample table of what both worksheets look like.

The first two rows of both worksheets will remain the same, but I would like to apply a code so that every time I open the workbook, it automatically moves expired rows - based on the expiry date column (J) - to the bottom of the table on the second worksheet (Expired Clearances).

Any help is appreciated!

Original Record

Internal Record

ARSC

Batch #

Ref. #

Legal Company Name

Last Name

First Name

Person Type

Assigned To

Status

Expiry Date

Submit date

primary

current company name

current status

telephone

email

notes

442

B-8388

C-4848

Company A

Chad

Chad

Worker

Cam

Granted

9/23/2017

9/21/2017

cam

Company A

Worker

444-444-4444

sample@sample.com

sample notes

<tbody>
</tbody>

 

[ttray33y]

Hello,

I am looking for some help creating VBA code that will transfer expired rows from the first worksheet - called "Valid Clearances" - to the second worksheet - called "Expired Clearances"

I initially troubleshooted this issue via google, but the codes I found never worked when I tried to apply them.

Below is a sample table of what both worksheets look like.

The first two rows of both worksheets will remain the same, but I would like to apply a code so that every time I open the workbook, it automatically moves expired rows - based on the expiry date column (J) - to the bottom of the table on the second worksheet (Expired Clearances).

Any help is appreciated!

Original Record

Internal Record

ARSC

Batch #

Ref. #

Legal Company Name

Last Name

First Name

Person Type

Assigned To

Status

Expiry Date

Submit date

primary

current company name

current status

telephone

email

notes

442

B-8388

C-4848

Company A

Chad

Chad

Worker

Cam

Granted

9/23/2017

9/21/2017

cam

Company A

Worker

444-444-4444

sample@sample.com

sample notes

<tbody>
</tbody>

try

Sub heec()


Dim lrow As Long
Dim i As Long


lrow = Sheet1.Cells(Rows.Count, 10).End(xlUp).Row
   
For i = 3 To lrow


    If Sheet1.Cells(i, 10) > Date Then
        With Sheet1
            .Range(.Cells(i, 1), .Cells(i, 17)).Cut Destination:=Sheet2.Range("A" & lrow).End(xlUp).Offset(1, 0)
        End With
    End If
    
Next i


        With Sheet1
            .Range("A3:A" & lrow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        End With


End Sub

 

[MrCameronExcel]

I've tried inputting this code into the VBA developer for both the Workbook, and sheet 1, but each time I try, Excel stops responding, and crashes on me. So frustrating!

Any idea why this may be happening?

Thank you,

Cameron

 

[ttray33y]

I've tried inputting this code into the VBA developer for both the Workbook, and sheet 1, but each time I try, Excel stops responding, and crashes on me. So frustrating!

Any idea why this may be happening?

Thank you,

Cameron

try inserting a new Module and paste it there, remove what you pasted in Sheet1 and ThisWorkbook. Also make sure your sheet names (#) corresponds to what the macro has eg. Sheet1 & Sheet2

 

[MrCameronExcel]

Firstly, thanks Tray. It is definitely coming along.

While working on this the other day, it wanted me to define the object, so I have replaced Sheet1 with Worksheet("Valid Clearances") and Sheet2 with Worksheet("Expired Clearances")

Now when I run the module, regardless of whether or not I used Sheet1 or Worksheet("Valid Clearances"), it says Sub or Function not defined!!

Code:

Sub heec()




Dim lrow As Long
Dim i As Long




lrow = Worksheet("Valid Clearances").Cells(Rows.Count, 10).End(xlUp).Row

For i = 3 To lrow




If Worksheet("Valid Clearances").Cells(i, 10) > Date Then
With Worksheet("Valid Clearances")
.Range(.Cells(i, 1), .Cells(i, 17)).Cut Destination:=Worksheet("Expired Clearances").Range("A" & lrow).End(xlUp).Offset(1, 0)
End With
End If

Next i




With Worksheet("Valid Clearances")
.Range("A3:A" & lrow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With




End Sub

 

[Fluff]

this
Worksheet("Valid Clearances")
should be
Worksheets("Valid Clearances")

You'll need to change this everytime you use Worksheet

 

[MrCameronExcel]

Thanks Fluff,

I have made this change (Worksheet to Worksheets), but when I try running the code now, Excel crashes.

After looking at the code more, I am wondering about the below changes:

1. lrow = Worksheet("Valid Clearances").Cells(Rows.Count, 10).End(xlUp).Row

Shouldn't the red ten be 17? Because 1 whole row is 17 cells wide.

2. If Worksheet("Valid Clearances").Cells(i, 10) >Date Then

Shouldn't the greater than symbol be a less than symbol (<)?


Just FYI, I have tried both the above changes together, but don't get the desired result. After making the above changes, the code ends up deleting all of the rows up until the expiry sate of December 2018 (which I find extremely strange), and it doesn't paste those rows in the 2nd worksheet.

 

[Fluff]

Try this

Sub heec()

    Dim lrow As Long
    Dim i As Long
    
    With Worksheets("Valid Clearances")
        lrow = .Cells.Find("*", after:=.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
        For i = 3 To lrow
            If .Range("J" & i) < Date Then
                .Range("A" & i).Resize(, 17).Cut Destination:=Worksheets("Expired Clearances").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            End If
        Next i
        
        .Range("A3:A" & lrow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With

End Sub

Is col A always populated, or can there be blanks?

 

[MrCameronExcel]

Hi Fluff,
There were blank cells in column A and others. I have since gone ahead and filled them ALLin.

The code is running now! But hasn't achieved all the desired results.

The code successfully cuts all of the expired rows from Worksheets("Valid Clearances"), but doesn't paste them onto Worksheets("Expired Clearances").

Do you think I need a row of code specifying to Paste?

Thank you, Cameron

 

[Fluff]

This line of code copies the cut range to the Expired Clearances sheet

.Range("A" & i).Resize(, 17).Cut Destination:=Worksheets("Expired Clearances").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)

Not sure why it's not working for you.
Do you get any error messages?
Do either of your sheets contain merged cells?