Find and Search then copy paste the Data with Nearest Expiry Date

Question

I wrote some code but its not completed because of my expertise in VBA. I have file consisting of 2 sheets. Sheet1 is current inventory and Sheet2 has orders.

Sheet2

[![enter image description here][1]][1]

Sheet1

[![enter image description here][2]][2]

I am looking for a help to complete the code. I just want that Code will pick up the Sheet2 Col"A" SKU's and will match that in Sheet1 Col"A" SKU's if same SKU's match.

Then

Code will search the nearest expiry date in Sheet1 Col"G" for those SKU's which have been matched and will copy the same row for those SKU's which expiry is going to end soon. After that Paste that data into "NewSheet" (The purpose of Expiry date is to sale those product which expiry is about to end so that we may not face the loss)

I have highlighted the Sheet1 Data with nearest expiry. your help will be much appreciated

MyCode.

    Sub Copypaste()

    Dim srchtrm As String
    Dim rng As Range, destRow As Long
    Dim shtSrc As Worksheet, shtDest As Worksheet
    Dim c As Range
    Dim i As Integer
    Dim Today As Date
    
    Set shtSrc = Sheet1
    Set shtDest = Sheet2
    destRow = 2
    Sheets.Add.Name = "NewSheet"

    Set rng = Application.Intersect(shtSrc.Range("A:A"), shtSrc.UsedRange)

    For Each c In rng.Cells
        If c.Value = Sheet1.Range("A2") Then
            
            c.EntireRow.Copy Sheets("NewSheet").Cells(destRow, 1)
          
            destRow = destRow + 1

        End If
    Next
    
End Sub

Code result in "New Sheet" [![enter image description here][3]][3]

Sheet Link https://drive.google.com/file/d/1yB1lsqm7K8Vk9EJMWRPHm05RDwTxVeKC/view?usp=sharing [1]: https://i.stack.imgur.com/v36cc.png [2]: https://i.stack.imgur.com/FVu2q.png [3]: https://i.stack.imgur.com/s6ygA.png

Answer 1

It seems to be solved by using sql.

Sub test()
    Dim Ws As Worksheet
    Dim strSQL As String, strU As String
    Dim sName(1 To 2) As Variant
    Dim i As Integer
    
    Set Ws = Sheets(3)

    For i = 1 To 2
        sName(i) = Sheets(i).Name
    Next i
        
    strSQL = "SELECT d.*  "
    strSQL = strSQL & " FROM [" & sName(2) & "$] as a left join "
    
    strSQL = strSQL & " ( select b.* FROM [" & sName(1) & "$] as b right join "
    strSQL = strSQL & "    ( select sku, min([Expiry Date]) as sday from [" & sName(1) & "$] group by sku) as c "
    strSQL = strSQL & " on b.sku = c.sku and  b.[Expiry Date]=c.sday) as d "
    
    strSQL = strSQL & "on a.sku = d.sku "
        
    exeSQL Ws, strSQL
    
    
End Sub

Sub exeSQL(Ws As Worksheet, strSQL As String)

    Dim Rs As Object  'ADODB.Recordset
    Dim strConn As String
    Dim i As Integer

    strConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & ThisWorkbook.FullName & ";" & _
            "Extended Properties=Excel 12.0;"
    
    Set Rs = CreateObject("ADODB.Recordset") 'New ADODB.Recordset
    
    Rs.Open strSQL, strConn
    
    If Not Rs.EOF Then
         With Ws
            .Range("a2").CurrentRegion.ClearContents
            For i = 0 To Rs.Fields.Count - 1
               .Cells(1, i + 1).Value = Rs.Fields(i).Name
            Next
            .Range("a2").CopyFromRecordset Rs
            .Columns.AutoFit
        End With
    End If
    Rs.Close
    Set Rs = Nothing
End Sub

Answer 2

i think this works.

Logic

1. Make an array of all skus in sheet 2 (orders)
2. Filter all stock lines (sheet 1) for those skus
3. Copy all stock lines to new sheet
4. remove all but earliest line for each stock line

This is all quite "neat" until the "brute force" removal in step 4 - let me know if it works and if there are any suggestions out there for how 4th step could be achieved more elegantly I'd love to hear about that

Option Explicit

Sub Copypaste()

    Dim destRow As Long
    Dim shtSrc As Worksheet, shtDest As Worksheet
    Dim i As Integer
    
    Set shtSrc = ThisWorkbook.Sheets("sheet1")
    Set shtDest = ThisWorkbook.Sheets("sheet2")
    destRow = 2
    
    'Step 1: identify order skus
    Dim order_skus As Range
    Set order_skus = shtDest.Range(shtDest.Range("a" & destRow), shtDest.Range("a" & shtDest.Rows.Count).End(xlUp))
    
    Dim arr() As Variant
    ReDim arr(order_skus.Rows.Count - 1)
    i = 0
    Dim r As Range
    For Each r In order_skus
      arr(i) = CStr(r.Value)
      i = i + 1
    Next r
    
    ' step 2: filter lines for skus we have orders
    shtSrc.UsedRange.AutoFilter
    shtSrc.UsedRange.AutoFilter field:=1, Criteria1:=arr, Operator:=xlFilterValues
    
    Dim ws_out As Worksheet
    Set ws_out = Sheets.Add
    ws_out.Name = "NewSheet"
    
    'step 3: copy filtered values
    shtSrc.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=ws_out.Range("a1")
    'remove auto filter
    shtSrc.UsedRange.AutoFilter
    
    'step 4: sort by sku and date and remove not first values for each sku
    ws_out.Range("a1").CurrentRegion.Sort key1:=ws_out.Range("a1"), order1:=xlAscending, Header:=xlYes, key2:=ws_out.Range("g1"), order2:=xlAscending
    Set r = ws_out.Range("a1")
    i = 1
    While Not IsEmpty(r.Offset(i, 0).Value)
      ' if this row sku same as previous
      If r.Offset(i, 0).Value = r.Offset(i - 1, 0).Value Then
        'remove the not-first row
        r.Offset(i, 0).EntireRow.Delete
      Else
        ' move to next item to check
        i = i + 1
      End If
    Wend
    
End Sub

Answer 3

Implementing new requirements

1. Clear "NewSheet" if it already exists
2. Exclude row where quantity = 0

Option Explicit

Sub Copypaste()

    Dim destRow As Long
    Dim shtSrc As Worksheet, shtDest As Worksheet
    Dim i As Integer
    
    Set shtSrc = ThisWorkbook.Sheets("sheet1")
    Set shtDest = ThisWorkbook.Sheets("sheet2")
    destRow = 2
    
    'Step 1: identify order skus
    Dim order_skus As Range
    Set order_skus = shtDest.Range(shtDest.Range("a" & destRow), shtDest.Range("a" & shtDest.Rows.Count).End(xlUp))
    
    Dim arr() As Variant
    ReDim arr(order_skus.Rows.Count - 1)
    i = 0
    Dim r As Range
    For Each r In order_skus
      arr(i) = CStr(r.Value)
      i = i + 1
    Next r
    
    ' step 2: filter lines for skus we have orders
    shtSrc.UsedRange.AutoFilter
    shtSrc.UsedRange.AutoFilter field:=1, Criteria1:=arr, Operator:=xlFilterValues
    
    ' test if sheet exists, create if not and clear if it does
    Dim ws_out As Worksheet
    Set ws_out = Nothing
    On Error Resume Next
    Set ws_out = Worksheets("NewSheet")
    On Error GoTo 0
    
    If ws_out Is Nothing Then
      Set ws_out = Sheets.Add
      ws_out.Name = "NewSheet"
    Else
      ws_out.Cells.Clear
    End If
    
    
    'step 3: copy filtered values
    shtSrc.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=ws_out.Range("a1")
    'remove auto filter
    shtSrc.UsedRange.AutoFilter
    
    'step 4: sort by sku and date and remove not first values for each sku
    ws_out.Range("a1").CurrentRegion.Sort key1:=ws_out.Range("a1"), order1:=xlAscending, Header:=xlYes, key2:=ws_out.Range("g1"), order2:=xlAscending
    Set r = ws_out.Range("a1")
    i = 1
    While Not IsEmpty(r.Offset(i, 0).Value)
      ' if this row sku same as previous
' delete row if already know sku OR qty is zero
      If r.Offset(i, 0).Value = r.Offset(i - 1, 0).Value Or r.Offset(i, 2).Value = 0 Then
        'remove the not-first row
        r.Offset(i, 0).EntireRow.Delete
      Else
        ' move to next item to check
        i = i + 1
      End If
    Wend
    
End Sub