Copy rows onto another worksheet based on multiple criteria (dynamic criteria)

asd1991

New Member
Joined
Feb 10, 2021
Messages
6
Office Version
  1. 365
Platform
  1. Windows
I'm trying to copy rows from one sheet to another worksheet based on a number of criteria (currently from a dropdown). I am currently able to do this for non-dynamic (non-changing) criteria using either an excel formula or VBA coda (which is much faster).

However, how can I set up my macro so that it captures the criteria selected in the drop down, rather than a pre-selected criteria in the code.

The drop down criteria is the following, where I would select start date, end date, product, and buy/sell. Preferably, I'd like the macro based on this dynamic selection which once run will produce the required data below.

1612957605886.png


Criteria (which will change as selected from dropdown)

1612957550835.png


  1. Excel Formula:
Excel Formula:
=IFERROR(INDEX(LNG_PORTFOLIO_2023_SG_HIST!$B$2:$AD$1000,SMALL(IF(COUNTIF(LNG_PORT_23_SG!$C$2,LNG_PORTFOLIO_2023_SG_HIST!$B$2:$B$1000)*COUNTIF(LNG_PORT_23_SG!$D$2,LNG_PORTFOLIO_2023_SG_HIST!$W$2:$W$1000)*COUNTIF(LNG_PORT_23_SG!$A$2,LNG_PORTFOLIO_2023_SG_HIST!$AC$2:$AC$1000)*COUNTIF(LNG_PORT_23_SG!$B$2,LNG_PORTFOLIO_2023_SG_HIST!$AD$2:$AD$1000),MATCH(ROW(LNG_PORTFOLIO_2023_SG_HIST!$C$2:$C$1000),ROW(LNG_PORTFOLIO_2023_SG_HIST!$C$2:$C$1000)),""),ROWS(LNG_PORTFOLIO_2023_SG_HIST!$A$1:B1)),COLUMNS(LNG_PORTFOLIO_2023_SG_HIST!$A$1:B1)),"")

2. VBA code

VBA Code:
Sub tgr()

    Dim wsData As Worksheet
    Dim wsDest As Worksheet
    Dim aCriteria() As String

    Set wsData = Sheets("LNG_PORTFOLIO_2023_SG_HIST")    'Copying FROM this worksheet (it contains your data)
    Set wsDest = Sheets("LNG_PORT_23_SG")        'Copying TO this worksheet (it is your destination)

    'Populate your array of values to filter for
    ReDim aFruit(2 To 4)
    aCriteria1(2) = "TTF M-1 Swap"
    aCriteria2(4) = "Validated"
    

    With wsData.Range("B2", wsData.Cells(wsData.Rows.Count, "B").End(xlUp))
        .AutoFilter 1, aCriteria, xlFilterValues   'Filter using the array, this avoids having to do a loop

        'Copy the filtered data (except the header row) and paste it as values
        .Offset(1).EntireRow.Copy
        wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues
        Application.CutCopyMode = False     'Remove the CutCopy border
        .AutoFilter     'Remove the filter
    End With

End Sub
 

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
I believe i've figured most of it out now, but could someone please help with referencing another worksheet in the below array criteria? I.e the criteria is in another worksheet but I don't know how to put that in. Please help

VBA Code:
Sub data_test_2()
'
' data_test_2 Macro
'

'
    With Worksheets("LNG_PORTFOLIO_2023_SG_HIST").Range("A1")
    
    .AutoFilter Field:=28, Operator:=xlFilterValues, Criteria2:=Array(2, "1/1/2023")

End With
End Sub
 
Upvote 0
Hello ASD1991,

Which column in your data set holds the start dates?
Which column in your data set holds the end dates?
Is Column A the products column?

Cheerio,
vcoolio
 
Upvote 0
Hello ASD1991,

Which column in your data set holds the start dates?
Which column in your data set holds the end dates?
Is Column A the products column?

Cheerio,
vcoolio
Hi Vcoolio,

I have managed to get the below code to work with the several different filter criteria that I have. I am now trying to copy the filtered cells and paste to the other worksheet. However, when I use the final line in the code it only copies and pastes the headings and none of the data. Would you know why that is?

Code used:
Option Explicit
Sub FilterDates()
Dim date1 As Long, date2 As Long, date3 As Long

date1 = Sheets("LNG_PORT_23_SG").Range("A2").Value2
date2 = Sheets("LNG_PORT_23_SG").Range("B2").Value2
date3 = Sheets("LNG_PORT_23_SG").Range("E2").Value2

With Sheets("LNG_PORTFOLIO_2023_SG_HIST").Range("A1:AC1")
.AutoFilter 28, ">=" & 1 * date1, 7
.AutoFilter 29, "<=" & 1 * date2, 7
.AutoFilter 9, ">=" & 1 * date3, 7
.AutoFilter Field:=1, Criteria1:=Sheets("LNG_PORT_23_SG").Range("C2").Value, Operator:=xlOr, Criteria2:=Sheets("LNG_PORT_23_SG").Range("C3").Value
.SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets("LNG_PORT_23_SG").Range("A11")

End With

End Sub
 
Upvote 0
Hello ASD1991,

Try adding:-

.Offset(1) in front of .SpecialCells

Cheerio,
vcoolio.
 
Upvote 0
Hello ASD1991,

Try adding:-

.Offset(1) in front of .SpecialCells

Cheerio,
vcoolio.
Hi Vcoolio - when I do that it seems to only copy the first row now with no headings or no other visible data. When I try again it shows an error "no cells were found".
 
Upvote 0
Hello ASD1991,

To prevent that error message when using the SpecialCells method, you must use the On Error Resume Next error handler:

Option Explicit
VBA Code:
Sub FilterDates()
Dim date1 As Long, date2 As Long, date3 As Long

date1 = Sheets("LNG_PORT_23_SG").Range("A2").Value2
date2 = Sheets("LNG_PORT_23_SG").Range("B2").Value2
date3 = Sheets("LNG_PORT_23_SG").Range("E2").Value2

With Sheets("LNG_PORTFOLIO_2023_SG_HIST").Range("A1:AC1")
On Error Resume Next
.AutoFilter 28, ">=" & 1 * date1, 7
.AutoFilter 29, "<=" & 1 * date2, 7
.AutoFilter 9, ">=" & 1 * date3, 7
.AutoFilter Field:=1, Criteria1:=Sheets("LNG_PORT_23_SG").Range("C2").Value, Operator:=xlOr, Criteria2:=Sheets("LNG_PORT_23_SG").Range("C3").Value
.SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets("LNG_PORT_23_SG").Range("A11")

End With

On Error GoTo 0

End Sub
 
Upvote 0
Further to my last post, it would be best if you uploaded a sample of your workbook so we can try and sort out the other problem for you.
Upload an exact replica of your file to a free file sharing site such as WeTransfer or Drop Box then post the link to your file back here.
Make sure that the sample shows your inputs and the expected outputs. If your data is sensitive then please use dummy data.
Please include the code that you already have.

Cheerio,
vcoolio.
 
Upvote 0
Further to my last post, it would be best if you uploaded a sample of your workbook so we can try and sort out the other problem for you.
Upload an exact replica of your file to a free file sharing site such as WeTransfer or Drop Box then post the link to your file back here.
Make sure that the sample shows your inputs and the expected outputs. If your data is sensitive then please use dummy data.
Please include the code that you already have.

Cheerio,
vcoolio.
Hi Vcoolio - here is the link to the file. MAIN_HA_FILE_TTF_test.xlsm
 
Upvote 0
Hello ASD1991,

Try it as follows:-

VBA Code:
Sub Test()

        Dim Dt1 As Long: Dt1 = Sheet9.Range("A2").Value
        Dim Dt2 As Long: Dt2 = Sheet9.Range("B2").Value
        Dim Dt3 As Long: Dt3 = Sheet9.Range("E2").Value
        Dim P1 As String: P1 = Sheet9.Range("C2").Value
        Dim P2 As String: P2 = Sheet9.Range("C3").Value
        
Application.ScreenUpdating = False

Sheet9.[A11].CurrentRegion.Offset(1).ClearContents

        With Sheet8.Range("A1:AC1")
                .AutoFilter 28, ">=" & 1 * Dt1
                .AutoFilter 29, "<=" & 1 * Dt2
                .AutoFilter 9, ">=" & 1 * Dt3
        With .Offset(1)
                .AutoFilter 1, P1, xlOr, P2
                .Copy Sheet9.[A12]
        End With
                .AutoFilter
        End With
        
Application.ScreenUpdating = True

End Sub

Cheerio,
vcoolio
 
Upvote 0

Forum statistics

Threads
1,213,539
Messages
6,114,221
Members
448,554
Latest member
Gleisner2

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