Is this possible...?

bluenose5709

New Member
Joined
Dec 15, 2012
Messages
23
Office Version
  1. 365
Hi,

I posted just now in another topic about Conditional formatting and shading of rows, however I am curious to know if I can take this a step further....?

For example:

"Sheet 1" contains my data and holds 500 rows. Each row has a Date in Column A. this date is manually populated in the following format 22/11/2022

Sheet 2 is a Summary sheet

Is there some way that I can use a Formula / VB to automatically make the individual lines from "Sheet 1" display in "Sheet 2" if a criteria is met?

For example, Lets say that in Sheet one there are 5 Rows where the date has already passed and 5 rows where the date occurs in the next 30 days, is there some magic where those 10 rows can be displayed on "Sheet 2", however if all dates are farther out than 30 days then nothing would appear on "Sheet 2"

Optimistically hoping for a Magician to help me on this and look forward to you answers.

thank you

Arran
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Yes, it's possible using a loop and determining where the next blank row is on the results (sheet2) tab.

Try adding the below to a normal module and make sure you update the first 6 declarations that suits your workbook (i.e.; tab names and first rows/columns of data on those tabs).

VBA Code:
Sub ProcessDates()

'declare variables
'***Make updates where <--Update is indicated below
Dim src As Worksheet: Set src = ThisWorkbook.Sheets("source") '<--Update source sheet name here
Dim res As Worksheet: Set res = ThisWorkbook.Sheets("results") '<--Update results sheet name here
Dim sFROW As Long: sFROW = 2 '<--Update the 2 to the first row of data on source sheet
Dim sFCOL As Long: sFCOL = 1 '<--Update the 1 to the first column of data on source sheet
Dim rFROW As Long: rFROW = 2 '<--Update the 2 to the first row of data on results sheet
Dim rFCOL As Long: rFCOL = 1 '<--Update the 1 to the first column of data on results sheet

Dim sLROW As Long: sLROW = src.Cells(sFROW, sFCOL).CurrentRegion.Rows.Count 'finds last row of source
Dim sLCOL As Long: sLCOL = src.UsedRange.Columns(src.UsedRange.Columns.Count).Column 'finds last column of source
Dim sRng As Range: Set sRng = src.Range(src.Cells(sFROW, sFCOL), src.Cells(sLROW, sFCOL)) 'sets range of dates to run through
Dim rLROW As Long, c As Range

On Error GoTo errHand 'error handler if something goes wrong
Application.ScreenUpdating = False 'turns off screenupdating

'set loop through source tab's range to find applicable dates
For Each c In sRng.Cells
    If CDate(c) < Date + 30 Then 'criteria checks if date in cell is less than 30 days from today
        'Will add row to results first open row
        rLROW = res.Cells(rFROW, rFCOL).CurrentRegion.Rows.Count 'finds last row of results
        src.Range(src.Cells(c.Row, sFCOL), src.Cells(c.Row, sLCOL)).Copy
        With res
            .Activate
            .Cells(rLROW + 1, rFCOL).Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
        End With
    End If
Next c

Application.ScreenUpdating = True 'turns screenupdating back on

Exit Sub

'if there's an error, the below message will display and screenupdating will resume
errHand:
MsgBox "Something went wrong.", vbCritical, "Error"
Application.ScreenUpdating = True

End Sub
 
Upvote 0
Yes, it's possible using a loop and determining where the next blank row is on the results (sheet2) tab.

Try adding the below to a normal module and make sure you update the first 6 declarations that suits your workbook (i.e.; tab names and first rows/columns of data on those tabs).

VBA Code:
Sub ProcessDates()

'declare variables
'***Make updates where <--Update is indicated below
Dim src As Worksheet: Set src = ThisWorkbook.Sheets("source") '<--Update source sheet name here
Dim res As Worksheet: Set res = ThisWorkbook.Sheets("results") '<--Update results sheet name here
Dim sFROW As Long: sFROW = 2 '<--Update the 2 to the first row of data on source sheet
Dim sFCOL As Long: sFCOL = 1 '<--Update the 1 to the first column of data on source sheet
Dim rFROW As Long: rFROW = 2 '<--Update the 2 to the first row of data on results sheet
Dim rFCOL As Long: rFCOL = 1 '<--Update the 1 to the first column of data on results sheet

Dim sLROW As Long: sLROW = src.Cells(sFROW, sFCOL).CurrentRegion.Rows.Count 'finds last row of source
Dim sLCOL As Long: sLCOL = src.UsedRange.Columns(src.UsedRange.Columns.Count).Column 'finds last column of source
Dim sRng As Range: Set sRng = src.Range(src.Cells(sFROW, sFCOL), src.Cells(sLROW, sFCOL)) 'sets range of dates to run through
Dim rLROW As Long, c As Range

On Error GoTo errHand 'error handler if something goes wrong
Application.ScreenUpdating = False 'turns off screenupdating

'set loop through source tab's range to find applicable dates
For Each c In sRng.Cells
    If CDate(c) < Date + 30 Then 'criteria checks if date in cell is less than 30 days from today
        'Will add row to results first open row
        rLROW = res.Cells(rFROW, rFCOL).CurrentRegion.Rows.Count 'finds last row of results
        src.Range(src.Cells(c.Row, sFCOL), src.Cells(c.Row, sLCOL)).Copy
        With res
            .Activate
            .Cells(rLROW + 1, rFCOL).Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
        End With
    End If
Next c

Application.ScreenUpdating = True 'turns screenupdating back on

Exit Sub

'if there's an error, the below message will display and screenupdating will resume
errHand:
MsgBox "Something went wrong.", vbCritical, "Error"
Application.ScreenUpdating = True

End Sub
Thank you so much for your assistance on this,

I have tried to use this but sadly i get:

Compile Error:

Invalid outside procedure


Any ideas?

I have amended the variables as:

'***Make updates where <--Update is indicated below
Dim src As Worksheet: Set src = ThisWorkbook.Sheets("Opportunity") '<--Update source sheet name here
Dim res As Worksheet: Set res = ThisWorkbook.Sheets("KPI") '<--Update results sheet name here
Dim sFROW As Long: sFROW = 2 '<--Update the 2 to the first row of data on source sheet
Dim sFCOL As Long: sFCOL = 4 '<--Update the 1 to the first column of data on source sheet
Dim rFROW As Long: rFROW = 19 '<--Update the 2 to the first row of data on results sheet
Dim rFCOL As Long: rFCOL = 2 '<--Update the 1 to the first column of data on results sheet
 
Upvote 0
can you try this? If you receive another error, can you take a screen shot of it and the row in the code that highlights?

VBA Code:
Sub ProcessDates()

'declare variables
'***Make updates where <--Update is indicated below
Dim src As Worksheet: Set src = ThisWorkbook.Sheets("Opportunity") '<--Update source sheet name here
Dim res As Worksheet: Set res = ThisWorkbook.Sheets("KPI") '<--Update results sheet name here
Dim sFROW As Long: sFROW = 2 '<--Update first row of data on source sheet to 2
Dim sFCOL As Long: sFCOL = 4 '<--Update first column of data on source sheet as A
Dim rFROW As Long: rFROW = 19 '<--Update first column of data on results sheet as A
Dim rFCOL As Long: rFCOL = 2 '<--Update first column of data on results sheet as A

Dim sLROW As Long: sLROW = src.Cells(sFROW, sFCOL).CurrentRegion.Rows.Count 'finds last row of source
Dim sLCOL As Long: sLCOL = src.UsedRange.Columns(src.UsedRange.Columns.Count).Column 'finds last column of source
Dim sRng As Range: Set sRng = src.Range(src.Cells(sFROW, sFCOL), src.Cells(sLROW, sFCOL)) 'sets range of dates to run through
Dim rLROW As Long, c As Range

On Error GoTo errHand 'error handler if something goes wrong
Application.ScreenUpdating = False 'turns off screenupdating

'set loop through source tab's range to find applicable dates
For Each c In sRng.Cells
    If CDate(c) < Date + 30 Then 'criteria checks if date in cell is less than 30 days from today
        src.Range(src.Cells(c.Row, sFCOL), src.Cells(c.Row, sLCOL)).Copy
        'Will add row to results first open row
        rLROW = res.Cells(res.Rows.Count, rFCOL).End(xlUp).Row 'finds last row of results

        With res
            .Activate
            .Cells(rLROW + 1, rFCOL).Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
        End With
    End If
Next c

Application.ScreenUpdating = True 'turns screenupdating back on

Exit Sub

'if there's an error, the below message will display and screenupdating will resume
errHand:
MsgBox "Something went wrong.", vbCritical, "Error"
Application.ScreenUpdating = True

End Sub
 
Upvote 0
I suggest that you update your Account details (or click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)

For example, if you have an appropriate Excel version, you can do it with a single formula in a single cell.

First, my sample data:

bluenose5709.xlsm
ABC
1DateAmountName
24/09/202287Name 1
316/08/202228Name 2
415/09/202271Name 3
519/08/202232Name 4
66/09/202273Name 5
719/05/202293Name 6
816/08/202219Name 7
93/09/20225Name 8
1015/08/202297Name 9
1121/08/202243Name 10
126/10/20222Name 11
1324/11/202228Name 12
148/12/202217Name 13
153/08/202215Name 14
1626/08/20223Name 15
1718/08/202223Name 16
1814/09/202255Name 17
191/03/202290Name 18
203/10/202237Name 19
2115/08/202211Name 20
2211/10/202216Name 21
2322/11/202215Name 22
2418/08/202289Name 23
254/11/20228Name 24
2614/02/202369Name 25
2724/09/202287Name 26
2823/08/202298Name 27
2910/10/202238Name 28
3027/09/20222Name 29
3131/07/202211Name 30
3214/08/202292Name 31
33
Sheet 1


Then the Summary sheet. I have included 2 options.
Cell A2 formula will list the relevant data in the same order as it was on Sheet1.
Cell E2 formula arranges the data in date order.

bluenose5709.xlsm
ABCDEFG
1DateAmountNameDateAmountName
24/09/202287Name 11/03/202290Name 18
316/08/202228Name 219/05/202293Name 6
419/08/202232Name 431/07/202211Name 30
56/09/202273Name 53/08/202215Name 14
619/05/202293Name 614/08/202292Name 31
716/08/202219Name 715/08/202297Name 9
83/09/20225Name 815/08/202211Name 20
915/08/202297Name 916/08/202228Name 2
1021/08/202243Name 1016/08/202219Name 7
113/08/202215Name 1418/08/202223Name 16
1226/08/20223Name 1518/08/202289Name 23
1318/08/202223Name 1619/08/202232Name 4
141/03/202290Name 1821/08/202243Name 10
1515/08/202211Name 2023/08/202298Name 27
1618/08/202289Name 2326/08/20223Name 15
1723/08/202298Name 273/09/20225Name 8
1831/07/202211Name 304/09/202287Name 1
1914/08/202292Name 316/09/202273Name 5
Summary
Cell Formulas
RangeFormula
A2:C19A2=FILTER('Sheet 1'!A2:C32,'Sheet 1'!A2:A32-30<TODAY(),"")
E2:G19E2=SORT(FILTER('Sheet 1'!A2:C32,'Sheet 1'!A2:A32-30<TODAY(),""),1)
Dynamic array formulas.
 
Upvote 0
can you try this? If you receive another error, can you take a screen shot of it and the row in the code that highlights?

VBA Code:
Sub ProcessDates()

'declare variables
'***Make updates where <--Update is indicated below
Dim src As Worksheet: Set src = ThisWorkbook.Sheets("Opportunity") '<--Update source sheet name here
Dim res As Worksheet: Set res = ThisWorkbook.Sheets("KPI") '<--Update results sheet name here
Dim sFROW As Long: sFROW = 2 '<--Update first row of data on source sheet to 2
Dim sFCOL As Long: sFCOL = 4 '<--Update first column of data on source sheet as A
Dim rFROW As Long: rFROW = 19 '<--Update first column of data on results sheet as A
Dim rFCOL As Long: rFCOL = 2 '<--Update first column of data on results sheet as A

Dim sLROW As Long: sLROW = src.Cells(sFROW, sFCOL).CurrentRegion.Rows.Count 'finds last row of source
Dim sLCOL As Long: sLCOL = src.UsedRange.Columns(src.UsedRange.Columns.Count).Column 'finds last column of source
Dim sRng As Range: Set sRng = src.Range(src.Cells(sFROW, sFCOL), src.Cells(sLROW, sFCOL)) 'sets range of dates to run through
Dim rLROW As Long, c As Range

On Error GoTo errHand 'error handler if something goes wrong
Application.ScreenUpdating = False 'turns off screenupdating

'set loop through source tab's range to find applicable dates
For Each c In sRng.Cells
    If CDate(c) < Date + 30 Then 'criteria checks if date in cell is less than 30 days from today
        src.Range(src.Cells(c.Row, sFCOL), src.Cells(c.Row, sLCOL)).Copy
        'Will add row to results first open row
        rLROW = res.Cells(res.Rows.Count, rFCOL).End(xlUp).Row 'finds last row of results

        With res
            .Activate
            .Cells(rLROW + 1, rFCOL).Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
        End With
    End If
Next c

Application.ScreenUpdating = True 'turns screenupdating back on

Exit Sub

'if there's an error, the below message will display and screenupdating will resume
errHand:
MsgBox "Something went wrong.", vbCritical, "Error"
Application.ScreenUpdating = True

End Sub

I have tried this and I simply receive the same "Something went wrong" but there is nothing that highlights in the code for me to screen shot for you?
 
Upvote 0
I suggest that you update your Account details (or click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)

For example, if you have an appropriate Excel version, you can do it with a single formula in a single cell.

First, my sample data:

bluenose5709.xlsm
ABC
1DateAmountName
24/09/202287Name 1
316/08/202228Name 2
415/09/202271Name 3
519/08/202232Name 4
66/09/202273Name 5
719/05/202293Name 6
816/08/202219Name 7
93/09/20225Name 8
1015/08/202297Name 9
1121/08/202243Name 10
126/10/20222Name 11
1324/11/202228Name 12
148/12/202217Name 13
153/08/202215Name 14
1626/08/20223Name 15
1718/08/202223Name 16
1814/09/202255Name 17
191/03/202290Name 18
203/10/202237Name 19
2115/08/202211Name 20
2211/10/202216Name 21
2322/11/202215Name 22
2418/08/202289Name 23
254/11/20228Name 24
2614/02/202369Name 25
2724/09/202287Name 26
2823/08/202298Name 27
2910/10/202238Name 28
3027/09/20222Name 29
3131/07/202211Name 30
3214/08/202292Name 31
33
Sheet 1


Then the Summary sheet. I have included 2 options.
Cell A2 formula will list the relevant data in the same order as it was on Sheet1.
Cell E2 formula arranges the data in date order.

bluenose5709.xlsm
ABCDEFG
1DateAmountNameDateAmountName
24/09/202287Name 11/03/202290Name 18
316/08/202228Name 219/05/202293Name 6
419/08/202232Name 431/07/202211Name 30
56/09/202273Name 53/08/202215Name 14
619/05/202293Name 614/08/202292Name 31
716/08/202219Name 715/08/202297Name 9
83/09/20225Name 815/08/202211Name 20
915/08/202297Name 916/08/202228Name 2
1021/08/202243Name 1016/08/202219Name 7
113/08/202215Name 1418/08/202223Name 16
1226/08/20223Name 1518/08/202289Name 23
1318/08/202223Name 1619/08/2022Name 4
141/03/202290Name 1821/08/202243Name 10
1515/08/202211Name 2023/08/202298Name 27
1618/08/202289Name 2326/08/20223Name 15
1723/08/202298Name 273/09/20225Name 8
1831/07/202211Name 304/09/202287Name 1
1914/08/202292Name 316/09/202273Name 5
Summary
I suggest that you update your Account details (or click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’) For example, if you have an appropriate Excel version, you can do it with a single formula in a single cell. First, my sample data:
bluenose5709.xlsm
ABC
1DateAmountName
24/09/202287Name 1
316/08/202228Name 2
415/09/202271Name 3
519/08/202232Name 4
66/09/202273Name 5
719/05/202293Name 6
816/08/202219Name 7
93/09/20225Name 8
1015/08/202297Name 9
1121/08/202243Name 10
126/10/20222Name 11
1324/11/202228Name 12
148/12/202217Name 13
153/08/202215Name 14
1626/08/20223Name 15
1718/08/202223Name 16
1814/09/202255Name 17
191/03/202290Name 18
203/10/202237Name 19
2115/08/202211Name 20
2211/10/202216Name 21
2322/11/202215Name 22
2418/08/202289Name 23
254/11/20228Name 24
2614/02/202369Name 25
2724/09/202287Name 26
2823/08/202298Name 27
2910/10/202238Name 28
3027/09/20222Name 29
3131/07/202211Name 30
3214/08/202292Name 31
33
Sheet 1
Then the Summary sheet. I have included 2 options. Cell A2 formula will list the relevant data in the same order as it was on Sheet1. Cell E2 formula arranges the data in date order.
bluenose5709.xlsm
ABCDEFG
1DateAmountNameDateAmountName
24/09/202287Name 11/03/202290Name 18
316/08/202228Name 219/05/202293Name 6
419/08/202232Name 431/07/202211Name 30
56/09/202273Name 53/08/202215Name 14
619/05/202293Name 614/08/202292Name 31
716/08/202219Name 715/08/202297Name 9
83/09/20225Name 815/08/202211Name 20
915/08/202297Name 916/08/202228Name 2
1021/08/202243Name 1016/08/202219Name 7
113/08/202215Name 1418/08/202223Name 16
1226/08/20223Name 1518/08/202289Name 23
1318/08/202223Name 1619/08/202232Name 4
141/03/202290Name 1821/08/202243Name 10
1515/08/202211Name 2023/08/202298Name 27
1618/08/202289Name 2326/08/20223Name 15
1723/08/202298Name 273/09/20225Name 8
1831/07/202211Name 304/09/202287Name 1
1914/08/202292Name 316/09/202273Name 5
Summary
Cell Formulas
RangeFormula
A2:C19A2=FILTER('Sheet 1'!A2:C32,'Sheet 1'!A2:A32-30<TODAY(),"")
E2:G19E2=SORT(FILTER('Sheet 1'!A2:C32,'Sheet 1'!A2:A32-30<TODAY(),""),1)
Dynamic array formulas.
XD=cls:spill|tx:]32[/XD]
Cell Formulas
RangeFormula
A2:C19A2=FILTER('Sheet 1'!A2:C32,'Sheet 1'!A2:A32-30<TODAY(),"")
E2:G19E2=SORT(FILTER('Sheet 1'!A2:C32,'Sheet 1'!A2:A32-30<TODAY(),""),1)
Dynamic array formulas.
Peter, apologies, i have updated my profile to highlight that i am using 365
 
Upvote 0
I have tried this and I simply receive the same "Something went wrong" but there is nothing that highlights in the code for me to screen shot for you?

Try this without the error handler. Let me know where that error lies.

VBA Code:
Sub ProcessDates()

'declare variables
'***Make updates where <--Update is indicated below
Dim src As Worksheet: Set src = ThisWorkbook.Sheets("Opportunity") '<--Update source sheet name here
Dim res As Worksheet: Set res = ThisWorkbook.Sheets("KPI") '<--Update results sheet name here
Dim sFROW As Long: sFROW = 2 '<--Update first row of data on source sheet to 2
Dim sFCOL As Long: sFCOL = 4 '<--Update first column of data on source sheet as A
Dim rFROW As Long: rFROW = 19 '<--Update first column of data on results sheet as A
Dim rFCOL As Long: rFCOL = 2 '<--Update first column of data on results sheet as A

Dim sLROW As Long: sLROW = src.Cells(sFROW, sFCOL).CurrentRegion.Rows.Count 'finds last row of source
Dim sLCOL As Long: sLCOL = src.UsedRange.Columns(src.UsedRange.Columns.Count).Column 'finds last column of source
Dim sRng As Range: Set sRng = src.Range(src.Cells(sFROW, sFCOL), src.Cells(sLROW, sFCOL)) 'sets range of dates to run through
Dim rLROW As Long, c As Range

'On Error GoTo errHand 'error handler if something goes wrong
Application.ScreenUpdating = False 'turns off screenupdating

'set loop through source tab's range to find applicable dates
For Each c In sRng.Cells
    If CDate(c) < Date + 30 Then 'criteria checks if date in cell is less than 30 days from today
        src.Range(src.Cells(c.Row, sFCOL), src.Cells(c.Row, sLCOL)).Copy
        'Will add row to results first open row
        rLROW = res.Cells(res.Rows.Count, rFCOL).End(xlUp).Row 'finds last row of results

        With res
            .Activate
            .Cells(rLROW + 1, rFCOL).Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
        End With
    End If
Next c

Application.ScreenUpdating = True 'turns screenupdating back on

Exit Sub

End Sub
 
Upvote 0

Forum statistics

Threads
1,213,524
Messages
6,114,117
Members
448,549
Latest member
brianhfield

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