Macro - Import and Copy Date from another workbook where date is upto 7 days later

[Yugo101]

Afternoon All.
Workbook 1 - Sheet 1 - Raw data
Workbook 2 - Sheet 1 - Cleansed data

Basically I have a report I download daily which contains a mass of data but majority of it I don't need. There is about 15 columns but Im only interested in 3 columns (below

Reference (A Column)	Due date (D Column)	Notes (E Column)
Ref 1	22/12/2024	This note

When I click the Marco I want to open file selector and select the Raw data work book and import the above 3 columns data from Workbook 1 copy and paste into workbook 2 where the due date is within 7 days of todays date.

I not had much interaction with macro's so any help would be amazing.

 

[Artik]

Try it:

Sub Import()
    Dim fileName As Variant
    Dim FDial As Office.FileDialog
    Dim wkb As Workbook
    Dim wks As Worksheet
    Dim vRawData As Variant
    Dim vCleanData As Variant
    Dim lRow As Long
    Dim i As Long
    Dim j As Long


    Set FDial = Application.FileDialog(msoFileDialogFilePicker)

    With FDial
        .Title = "Zaznacz pliki do przetworzenia"
        .AllowMultiSelect = False

        .InitialFileName = CurDir & "\"
        .Filters.Delete
        .Filters.Add "Excel files", "*.xls*"

        If .Show <> -1 Then
            Exit Sub
        Else
            fileName = .SelectedItems(1)
        End If
    End With

    Set wkb = Application.Workbooks.Open(fileName:=fileName, ReadOnly:=True)

    'first sheet in the workbook or a sheet with a specific name
    Set wks = wkb.Worksheets(1)    ' or wkb.Worksheets("Sheet1")

    'Get all the data from the raw sheet
    vRawData = wks.Range("A1").CurrentRegion.Value
    'close the source workbook without saving
    wkb.Close SaveChanges:=False

    'prepare the resulting table with maximum dimensions
    ReDim vCleanData(1 To 3, 1 To UBound(vRawData) - 1)

    For i = 2 To UBound(vRawData)
        If vRawData(i, 4) <= Date + 7 Then
            j = j + 1
            vCleanData(1, j) = vRawData(i, 1)    'data from col.A
            vCleanData(2, j) = vRawData(i, 4)    'data from col.D
            vCleanData(3, j) = vRawData(i, 5)    'data from col.E
        End If
    Next i

    If j > 0 Then
        'remove redundant columns
        ReDim Preserve vCleanData(1 To 3, 1 To j)
        'transpose the data array
        vCleanData = TransposeDim(vCleanData)

        With ThisWorkbook.Worksheets("Sheet1")
            'find the first free row in the target sheet
            lRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
            'insert the data
            .Cells(lRow, "A").Resize(UBound(vCleanData) + 1, 3).Value = vCleanData
        End With

        MsgBox "Done", vbInformation
    Else
        MsgBox "No data found that meets criterion: Today + 7.", vbInformation
    End If
End Sub


Function TransposeDim(vData As Variant) As Variant

    With CreateObject("New:{8BD21D20-EC42-11CE-9E0D-00AA006002F3}")
        .Column = vData
        TransposeDim = .List
    End With

End Function

Artik

 

[Fuji]

try

Sub test()
    Dim fn$, s$(1), ws As Worksheet, i&, x
    Const wsName$ = "Raw Data"
    fn = Application.GetOpenFilename("Excel Files,*.xls;*.xlsx;*.xlsm;*.xlsb")
    If fn = "False" Then Exit Sub
    x = ExecuteExcel4Macro("'" & Application.Replace(fn, _
        InStrRev(fn, "\") + 1, 0, "[") & "]" & wsName & "'!r1c1")
    If IsError(x) Then MsgBox "No sheet named """ & wsName & """": Exit Sub
    s(0) = "Select Reference, `Due Date`, Notes From `Raw Data$` " & _
         "Where `Due Date` - Date() <=7;"
    s(1) = "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & _
           fn & ";Extended Properties='Excel 12.0;HDR=Yes';"
    Set ws = ThisWorkbook.Sheets("Cleansed data")
    ws.[a1].CurrentRegion.ClearContents
    With CreateObject("ADODB.Recordset")
        .Open s(0), s(1)
        For i = 0 To .Fields.Count - 1
            ws.Cells(1, i + 1) = .Fields(i).Name
        Next
        ws.[a2].CopyFromRecordset .DataSource
    End With
End Sub

 

[Yugo101]

Thank you for the responses, ill try these both out and let know what works