Yes it can.
Assuming you have:
* The filter criteria in worksheet "
FILTER FOR SUPPLIER"
* The supplier data in "
SUPPLIER" worksheet
* The result in "
RESULT" worksheet
* The "
DATELIST" worksheet - for referencing the date to the column reference
For the
SUPPLIER data, I assume that you have more Dates than shown in your sample.
View attachment 74590
The
DATELIST data:
View attachment 74591
And your
FILTER FOR SUPPLIER worksheet:
View attachment 74594
(In column E, I show the row number, and in column F, I show the variable used to capture and store the information entered into the cells)
For the FILTER FOR SUPPLIER function, I assume that you will only search and copy 1 supplier at a time.
The GO button will be linked to the VBA code
modCopySupplier:
VBA Code:
Option Explicit
Option Compare Text
Sub modCopySupplier()
'===================================
' Search and copy supplier data
' for the date range specified
'===================================
Dim lngRow As Long
Dim lngLasRow As Long
Dim WB As Workbook
Dim wsFilter As Worksheet
Dim wsSupp As Worksheet
Dim wsResult As Worksheet
Dim wsDateList As Worksheet
Dim txtSupplier As String
Dim dtDateFrom As Date
Dim dtDateTo As Date
Dim lngDateRow As Long
Dim lngLasDateRow As Long
Dim ColFrom As String
Dim ColTo As String
'==========================================================
' Positively identify this workbook and its worksheets
' then you can refer the worksheets by the nickname
'==========================================================
Set WB = ActiveWorkbook 'This workbook
Set wsFilter = WB.Sheets("FILTER FOR SUPPLIER")
Set wsSupp = WB.Sheets("SUPPLIER")
Set wsResult = WB.Sheets("RESULT")
Set wsDateList = WB.Sheets("DATELIST")
'====================================================
' Clean out any old data in the RESULT worksheet
'====================================================
wsResult.Cells.ClearContents
'===================
' Get the input
'===================
txtSupplier = Trim(wsFilter.Range("C2"))
dtDateFrom = wsFilter.Range("C4")
dtDateTo = wsFilter.Range("C6")
'====================================================
' Error trap: If any of the data cells are blank
'====================================================
If txtSupplier = "" Or _
dtDateFrom = 0 Or _
dtDateTo = 0 Then
'=========================================
' Show error message on the StatusBar
' (bottom left of screen)
'=========================================
Application.StatusBar = "Information is not complete!"
'==========
' Quit
'==========
Exit Sub
End If
'--------------------------------------------------
' Assume that the inputs are correct,
' we can now begin to search and copy the data
'--------------------------------------------------
'========================================================
' First, find the last data row in the SUPPLIER list
' so the program knows when to stop searching
'========================================================
lngLasRow = wsSupp.Range("A1048576").End(xlUp).row
'================================================
' Now we search for the supplier
' by comparing the txtSupplier with column A
' in the SUPPLIER worksheet
'================================================
For lngRow = 2 To lngLasRow
'===================================================
' Compare txtSupplier with the data in column A
'===================================================
If txtSupplier = wsSupp.Range("A" & lngRow) Then
'===================================================
' Found the Supplier in this row
' write this in the RESULTS worksheet, column A
'===================================================
wsResult.Range("A1") = "SUPPLIER"
wsResult.Range("A2") = wsSupp.Range("A" & lngRow)
'===============================================
' Next, we are going to search the DateList
' So we find the last data row
'===============================================
lngLasDateRow = wsDateList.Range("A1048576").End(xlUp).row
'==============================================
' Now we have to find the column reference
' for the first and second dates.
' First, let's find the first date
'==============================================
For lngDateRow = 2 To lngLasDateRow
'=========================
' Find the first date
'=========================
If wsDateList.Range("A" & lngDateRow) = dtDateFrom Then
'==============================
' Found the first date.
' Get the column reference
'==============================
ColFrom = wsDateList.Range("B" & lngDateRow)
Exit For
End If
Next
'======================================
' Next, let's find the second date
'======================================
For lngDateRow = 2 To lngLasDateRow
'==========================
' Find the second date
'==========================
If wsDateList.Range("A" & lngDateRow) = dtDateTo Then
'==============================
' Found the first date.
' Get the column reference
'==============================
ColTo = wsDateList.Range("B" & lngDateRow)
Exit For
End If
Next
'===================
' Stop checking
'===================
Exit For
End If
Next
'===========================================
' Finally, copy the data from SUPPLIER
' by copying the date headings
' and the supplier data
'===========================================
wsResult.Activate
wsSupp.Range(ColFrom & "1:" & ColTo & "1").Copy
wsResult.Range("B1").PasteSpecial xlPasteValues
wsSupp.Range(ColFrom & lngRow & ":" & ColTo & lngRow).Copy
wsResult.Range("B2").PasteSpecial xlPasteValues
wsResult.Columns.AutoFit
wsResult.Range("A3").Select
End Sub
Hope this helps.