Auto transferring expired rows to 2nd worksheet

M

MrCameronExcel

New Member
Joined
Apr 21, 2017
Messages
43
Office Version
  1. 365
Platform
  1. Windows
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!


[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]Original Record[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Internal Record[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ARSC[/TD]
[TD]Batch #[/TD]
[TD]Ref. #[/TD]
[TD]Legal Company Name[/TD]
[TD]Last Name[/TD]
[TD]First Name[/TD]
[TD]Person Type[/TD]
[TD]Assigned To[/TD]
[TD]Status[/TD]
[TD]Expiry Date[/TD]
[TD]Submit date[/TD]
[TD]primary[/TD]
[TD]current company name[/TD]
[TD]current status[/TD]
[TD]telephone[/TD]
[TD]email[/TD]
[TD]notes[/TD]
[/TR]
[TR]
[TD]442[/TD]
[TD]B-8388[/TD]
[TD]C-4848[/TD]
[TD]Company A[/TD]
[TD]Chad[/TD]
[TD]Chad[/TD]
[TD]Worker[/TD]
[TD]Cam[/TD]
[TD]Granted[/TD]
[TD]9/23/2017[/TD]
[TD]9/21/2017[/TD]
[TD]cam[/TD]
[TD]Company A[/TD]
[TD]Worker[/TD]
[TD]444-444-4444[/TD]
[TD]sample@sample.com[/TD]
[TD]sample notes[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
 

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
Sort by date Sort by votes
MrCameronExcel said:
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!


[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]Original Record[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Internal Record[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ARSC[/TD]
[TD]Batch #[/TD]
[TD]Ref. #[/TD]
[TD]Legal Company Name[/TD]
[TD]Last Name[/TD]
[TD]First Name[/TD]
[TD]Person Type[/TD]
[TD]Assigned To[/TD]
[TD]Status[/TD]
[TD]Expiry Date[/TD]
[TD]Submit date[/TD]
[TD]primary[/TD]
[TD]current company name[/TD]
[TD]current status[/TD]
[TD]telephone[/TD]
[TD]email[/TD]
[TD]notes[/TD]
[/TR]
[TR]
[TD]442[/TD]
[TD]B-8388[/TD]
[TD]C-4848[/TD]
[TD]Company A[/TD]
[TD]Chad[/TD]
[TD]Chad[/TD]
[TD]Worker[/TD]
[TD]Cam[/TD]
[TD]Granted[/TD]
[TD]9/23/2017[/TD]
[TD]9/21/2017[/TD]
[TD]cam[/TD]
[TD]Company A[/TD]
[TD]Worker[/TD]
[TD]444-444-4444[/TD]
[TD]sample@sample.com[/TD]
[TD]sample notes[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
Click to expand...















try
Code: 
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
 
Upvote 0
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
 
Upvote 0
MrCameronExcel said:
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
Click to expand...
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
 
Upvote 0
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
 
Upvote 0
this
Worksheet("Valid Clearances")
should be
Worksheets("Valid Clearances")

You'll need to change this everytime you use Worksheet
 
Upvote 0
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.
 
Upvote 0
Try this
Code: 
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?
 
Upvote 0
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
 
Upvote 0
This line of code copies the cut range to the Expired Clearances sheet
Code: 
.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?
 
Upvote 0
You must log in or register to reply here.

Similar threads

W
  • Solved
Moving/transferring data between tables with matching column names, not by column order - vba
Replies
5
Views
952
Alex Blakenburg
A
k3yn0t3
  • Solved
INDEX(MATCH()) pulling wrong row data & Macro to duplicate sheets with formulas
Replies
4
Views
574
Alex Blakenburg
A
J
  • Question Question
VBA - transfer data from one worksheet to another based on unique reference
Replies
1
Views
2K
DanteAmor
DanteAmor
S
  • Question Question
VBA code to automatically send several different emails (body different) based on cell data
Replies
0
Views
1K
Schanemans
S
K
  • Solved
Check & Update existing rows of data to fill in the blanks
Replies
1
Views
626
Kemidan2014
K

Forum statistics

Threads
1,224,823
Messages
6,181,175
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top