Adding time filter to existing VBA code

[2avrham]

Hi,

I have VBA code that "knows" how to take several txt files from one folder and combine them to one excel sheet.

I need your help to modify the code that it will take files only from the last week (last 7 days).

How can I do it?

Thanks!

Code:

Option Explicit

#If VBA7 Then
Private Declare PtrSafe Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long

Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
lpExitCode As Long) As Long
#Else
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long

Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
lpExitCode As Long) As Long
#End If

Public Const PROCESS_QUERY_INFORMATION = &H400
Public Const STILL_ACTIVE = &H103

Public Sub ShellAndWait(ByVal PathName As String, Optional WindowState)
Dim hProg As Long
Dim hProcess As Long, ExitCode As Long
If IsMissing(WindowState) Then WindowState = 1
hProg = Shell(PathName, WindowState)
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, hProg)
Do

GetExitCodeProcess hProcess, ExitCode
DoEvents
Loop While ExitCode = STILL_ACTIVE
End Sub


Sub Merge_CSV_Files()
Dim BatFileName As String
Dim TXTFileName As String
Dim XLSFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim DefPath As String
Dim Wb As Workbook
Dim oApp As Object
Dim oFolder
Dim foldername

BatFileName = Environ("Temp") & _
"\CollectCSVData" & Format(Now, "dd-mm-yy-h-mm-ss") & ".bat"
TXTFileName = Environ("Temp") & _
"\AllCSV" & Format(Now, "dd-mm-yy-h-mm-ss") & ".txt"


DefPath = "C:\Users\aklipper\Desktop\Macro"
If Right(DefPath, 1) <> "" Then
DefPath = DefPath & ""
End If


If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else

FileExtStr = ".xlsx": FileFormatNum = 51


End If


XLSFileName = DefPath & "Combine_units " & _
Format(Now, "dd-mmm-yyyy h-mm-ss") & FileExtStr


Set oApp = CreateObject("Shell.Application")
Set oFolder = oApp.BrowseForFolder(0, "Select folder with txt files", 512)
If Not oFolder Is Nothing Then
foldername = oFolder.Self.Path
If Right(foldername, 1) <> "" Then
foldername = foldername & ""
End If


Open BatFileName For Output As #1
Print #1 , "Copy " & Chr(34) & foldername & "*.txt" _
& Chr(34) & " " & TXTFileName
Close #1


ShellAndWait BatFileName, 0
If Dir(TXTFileName) = "" Then
MsgBox "There are no csv files in this folder"
Kill BatFileName
Exit Sub
End If


Application.ScreenUpdating = False
Workbooks.OpenText Filename:=TXTFileName, Origin:=xlWindows, StartRow _
:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=True, _
Space:=False, Other:=False


Set Wb = ActiveWorkbook
Application.DisplayAlerts = False
Wb.SaveAs Filename:=XLSFileName, FileFormat:=FileFormatNum
Application.DisplayAlerts = True

Wb.Close savechanges:=False
MsgBox "You find the Excel file here: " & vbNewLine & XLSFileName

Kill BatFileName
Kill TXTFileName

Application.ScreenUpdating = True
End If
End Sub

 

[2avrham]

I also have this code:

Sub ImportCSVsWithReference()
'UpdatebyKutoolsforExcel20151214
Dim xSht As Worksheet
Dim xWb As Workbook
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder [Kutools for Excel]"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
Set xSht = ThisWorkbook.ActiveSheet
If MsgBox("Clear the existing sheet before importing?", vbYesNo, "Kutools for Excel") = vbYes Then xSht.UsedRange.Clear
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "" & "*.txt")
Do While xFile <> ""
Set xWb = Workbooks.Open(xStrPath & "" & xFile)
Columns(1).Insert xlShiftToRight
Columns(1).SpecialCells(xlBlanks).Value = ActiveSheet.Name
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Close False
xFile = Dir
Loop
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox "no txt files ", , "Kutools for Excel"
End Sub

it do the same