Import Excel Files By reading Modified Time

[Kalfel]

Hi Team,

Am having a macro to import multiple csv file and to consolidate it as a single sheet.
No my requirement is to import only files modified from 2PM to 11 PM. Can any one please help.

 

[sastoka]

Hi there

I don't think there is a property that is just modified. The closest one I can think of is "Last Save Time"

If you're ok working with the last save time instead of the last modified time we should be able to help.

Regards

 

[sastoka]

I've tried something

Dim shortmodifdate As Variant
Dim longmodifdate As Variant
Dim modiftime As Variant
Dim entrytime As Double
Dim exittime As Double


Dim tosave As Boolean

Sub iftimeok()


longmodifdate = ThisWorkbook.BuiltinDocumentProperties("Last Save Time")
entrytime = 0.583331 ' numeric value for 2:00 pm you can change if needed
exittime = 0.958331 ' numerci value for 11:00 pm you can change if needed


longmodifdate = CDbl(longmodifdate)
shortmodifdate = CLng(longmodifdate)
modiftime = longmodifdate - shortmodifdate ' return only the time



If modiftime < 0 Then ' after noon the time will be negative so we need to revert back to positive value
    modiftime = modiftime * (-1)
End If

If modiftime > entrytime And modiftime > exittime Then
    tosave = True ' When true the last time modified is between 2pm and 11 pm
End If

If tosave = True Then
    'Do what you need to do
Else
    'do what you need to do
End If




End Sub

I've used a boolean.

It will be true if the time is between 2pm and 11pm.

I've also hard coded the numeric value for 2pm and 11pm and assign them to varaible. That mean you can modify the time whenever you want.

PLEASE BE AWARE > TRY THIS MACRO IN A COPY OF YOUR WORKBOOK FIRST.


Regards.

 

[Kalfel]

<code style="margin: 0px; padding: 0px; border: 0px; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; white-space: inherit;">Option Explicit
Sub ImportCSVs()
Dim fPath As String
Dim fCSV As String
Dim wbCSV As Workbook
Dim wbMST As Workbook

Set wbMST = ThisWorkbook
fPath = "C:\Users\***\Documents\test" 'path to CSV files, include the final \
Application.ScreenUpdating = False 'speed up macro
Application.DisplayAlerts = False 'no error messages, take default answers
fCSV = Dir(fPath & "*.csv") 'start the CSV file listing

On Error Resume Next
Do While Len(fCSV) > 0
Set wbCSV = Workbooks.Open(fPath & fCSV) 'open a CSV file
wbMST.Sheets(ActiveSheet.Name).Delete 'delete sheet if it exists
ActiveSheet.Move After:=wbMST.Sheets(wbMST.Sheets.Count) 'move new sheet into Mstr
Columns.AutoFit 'clean up display
fCSV = Dir 'ready next CSV
Loop

Application.ScreenUpdating = True
Set wbCSV = Nothing
Call Collect
Call Worksheet_Activate
End Sub
Sub Collect()
Dim myInSht As Worksheet
Dim myOutSht As Worksheet
Dim aRow As Range
Dim aCol As Range
Dim myInCol As Range
Dim myOutCol As Range
Dim calcState As Long
Dim scrUpdateState As Long
Dim cell As Range
Dim iLoop As Long, jLoop As Long

jLoop = 2

' loop through the worksheets
For Each myInSht In ActiveWorkbook.Worksheets
' pick only the worksheets of interest
'If myInSht.Name = "a" Or myInSht.Name = "aa" Or myInSht.Name = "aaa" Then
' find the columns of interest in the worksheet
For Each aCol In myInSht.UsedRange.Columns
Set myOutCol = Nothing
If aCol.Cells(1, 1).Value = "timestamp" Then Set myOutCol = Sheets("Summary").Range("B2:B1000")
If aCol.Cells(1, 1).Value = "ip" Then Set myOutCol = Sheets("Summary").Range("C2:C1000")
If aCol.Cells(1, 1).Value = "protocol" Then Set myOutCol = Sheets("Summary").Range("D2:D1000")
If aCol.Cells(1, 1).Value = "port" Then Set myOutCol = Sheets("Summary").Range("E2:E1000")
If aCol.Cells(1, 1).Value = "hostname" Then Set myOutCol = Sheets("Summary").Range("F2:F1000")
If aCol.Cells(1, 1).Value = "tag" Then Set myOutCol = Sheets("Summary").Range("G2:G1000")
If aCol.Cells(1, 1).Value = "asn" Then Set myOutCol = Sheets("Summary").Range("I2:I1000")
If aCol.Cells(1, 1).Value = "geo" Then Set myOutCol = Sheets("Summary").Range("J2:J1000")
If aCol.Cells(1, 1).Value = "region" Then Set myOutCol = Sheets("Summary").Range("K2:K1000")
If aCol.Cells(1, 1).Value = "naics" Then Set myOutCol = Sheets("Summary").Range("L2:L1000")
If aCol.Cells(1, 1).Value = "sic" Then Set myOutCol = Sheets("Summary").Range("M2:M1000")
If aCol.Cells(1, 1).Value = "server_name" Then Set myOutCol = Sheets("Summary").Range("H2:H1000")

If Not myOutCol Is Nothing Then
' don't move the top line, it contains the headers - no data
Set myInCol = aCol
Set myInCol = myInCol.Offset(1, 0).Resize(myInCol.Rows.Count, myInCol.Columns.Count)
' transfer data from the project tab to the consolidated tab
iLoop = jLoop
For Each aRow In myInCol.Rows
myOutCol.Cells(iLoop, 1).Value = aRow.Cells(1, 1).Value
iLoop = iLoop + 1
Next aRow
End If
Next aCol
'End If
If iLoop > jLoop Then jLoop = iLoop
Next myInSht
End Sub
Sub Worksheet_Activate()
'Updateby20150305
Dim xSheet As Worksheet
Dim xRow As Integer
Dim calcState As Long
Dim scrUpdateState As Long
Application.ScreenUpdating = False
xRow = 4
With Me
.Columns(1).ClearContents
'.Cells(1, 1) = "Summary"
'.Cells(1, 1).Name = "Summary"
End With
For Each xSheet In Application.Worksheets
If xSheet.Name <> Me.Name Then
xRow = xRow + 1
With xSheet
.Range("P1").Name = "Start_" & xSheet.Index
.Hyperlinks.Add Anchor:=.Range("P1"), Address:="", _
SubAddress:="Summery", TextToDisplay:="time stamp"
End With
Me.Hyperlinks.Add Anchor:=Me.Cells(xRow, 1), Address:="", _
SubAddress:="Start_" & xSheet.Index, TextToDisplay:=xSheet.Name
End If
Next
Application.ScreenUpdating = True
End Sub</code>

 

[Kalfel]

Above is my code to create consolidate sheet. Any idea to invoke my requirement in this. Please guide.

 

[sastoka]

Please use the TAG CODE next time you post some vba, it makes it easier to read, understand and work with.

Here is my try.

I'm absolutely not sure it will work.

TRY THIS IN A COPY FIRST

Option Explicit

Dim xRow As Integer

Dim fPath As String, fCSV As String

Dim wbCSV As Workbook, wbMST As Workbook

Dim myInSht As Worksheet, myOutSht As Worksheet, xSheet As Worksheet

Dim aRow As Range, aCol As Range, myInCol As Range, myOutCol As Range, cell As Range


Dim shortmodifdate As Variant, longmodifdate As Variant, modiftime As Variant, entrytime As Double, exittime As Double

Dim calcState As Long, scrUpdateState As Long, iLoop As Long, jLoop As Long, calcState As Long, scrUpdateState As Long






Sub ImportCSVs()

Set wbMST = ThisWorkbook
fPath = "C:\Users\***\Documents\test" 'path to CSV files, include the final \
Application.ScreenUpdating = False 'speed up macro
Application.DisplayAlerts = False 'no error messages, take default answers
fCSV = Dir(fPath & "*.csv") 'start the CSV file listing

OnErrorResumeNext
DoWhile Len(fCSV) > 0
    Set wbCSV = Workbooks.Open(fPath & fCSV) 'open a CSV file
    wbMST.Sheets(ActiveSheet.Name).Delete 'delete sheet if it exists
    ActiveSheet.Move After:=wbMST.Sheets(wbMST.Sheets.Count) 'move new sheet into Mstr
    Columns.AutoFit 'clean up display
    fCSV = Dir 'ready next CSV
    
    longmodifdate = ThisWorkbook.BuiltinDocumentProperties("Last Save Time")
    entrytime = 0.583331 ' numeric value for 2:00 pm you can change if needed
    exittime = 0.958331 ' numerci value for 11:00 pm you can change if needed


    longmodifdate = CDbl(longmodifdate)
    shortmodifdate = CLng(longmodifdate)
    modiftime = longmodifdate - shortmodifdate ' return only the time



If modiftime < 0 Then ' after noon the time will be negative so we need to revert back to positive value
    modiftime = modiftime * (-1)
End If

If modiftime > entrytime And modiftime > exittime Then
    tosave = True ' When true the last time modified is between 2pm and 11 pm
End If

If tosave = True Then
    Set wbCSV = Nothing
    Call Collect
    Call Worksheet_Activate
Else
    'do what you need to do
End If


    
    
Loop

Application.ScreenUpdating = True



End Sub


Sub Collect()



jLoop = 2

' loop through the worksheets
For Each myInSht In ActiveWorkbook.Worksheets

' pick only the worksheets of interest
'If myInSht.Name = "a" Or myInSht.Name = "aa" Or myInSht.Name = "aaa" Then
' find the columns of interest in the worksheet
    For Each aCol In myInSht.UsedRange.Columns
        Set myOutCol = Nothing
        If aCol.Cells(1, 1).Value = "timestamp" Then Set myOutCol = Sheets("Summary").Range("B2:B1000")
        If aCol.Cells(1, 1).Value = "ip" Then Set myOutCol = Sheets("Summary").Range("C2:C1000")
        If aCol.Cells(1, 1).Value = "protocol" Then Set myOutCol = Sheets("Summary").Range("D2:D1000")
        If aCol.Cells(1, 1).Value = "port" Then Set myOutCol = Sheets("Summary").Range("E2:E1000")
        If aCol.Cells(1, 1).Value = "hostname" Then Set myOutCol = Sheets("Summary").Range("F2:F1000")
        If aCol.Cells(1, 1).Value = "tag" Then Set myOutCol = Sheets("Summary").Range("G2:G1000")
        If aCol.Cells(1, 1).Value = "asn" Then Set myOutCol = Sheets("Summary").Range("I2:I1000")
        If aCol.Cells(1, 1).Value = "geo" Then Set myOutCol = Sheets("Summary").Range("J2:J1000")
        If aCol.Cells(1, 1).Value = "region" Then Set myOutCol = Sheets("Summary").Range("K2:K1000")
        If aCol.Cells(1, 1).Value = "naics" Then Set myOutCol = Sheets("Summary").Range("L2:L1000")
        If aCol.Cells(1, 1).Value = "sic" Then Set myOutCol = Sheets("Summary").Range("M2:M1000")
        If aCol.Cells(1, 1).Value = "server_name" Then Set myOutCol = Sheets("Summary").Range("H2:H1000")
    
        If Not myOutCol Is Nothing Then
        ' don't move the top line, it contains the headers - no data
            Set myInCol = aCol
            Set myInCol = myInCol.Offset(1, 0).Resize(myInCol.Rows.Count, myInCol.Columns.Count)
        ' transfer data from the project tab to the consolidated tab
            iLoop = jLoop
            For Each aRow In myInCol.Rows
                myOutCol.Cells(iLoop, 1).Value = aRow.Cells(1, 1).Value
                iLoop = iLoop + 1
            Next aRow
        End If
    Next aCol
    If iLoop > jLoop Then jLoop = iLoop
        Next myInSht
End Sub
Sub Worksheet_Activate()
        'Updateby20150305

Application.ScreenUpdating = False


xRow = 4
With Me
    .Columns(1).ClearContents
    '.Cells(1, 1) = "Summary"
    '.Cells(1, 1).Name = "Summary"
End With
For Each xSheet In Application.Worksheets
    If xSheet.Name <> Me.Name Then
        xRow = xRow + 1
        With xSheet
            .Range("P1").Name = "Start_" & xSheet.Index
            .Hyperlinks.Add Anchor:=.Range("P1"), Address:="", _
            SubAddress:="Summery", TextToDisplay:="time stamp"
        End With
        Me.Hyperlinks.Add Anchor:=Me.Cells(xRow, 1), Address:="", _
        SubAddress:="Start_" & xSheet.Index, TextToDisplay:=xSheet.Name
    End If
Next

Application.ScreenUpdating = True

End Sub

Some note.

I did a bit of cleaning in the code, not much. I grouped all your variable at the top.

Try not to use a variable named Cell, especially is you defined it as a RANGE, as Cell is considered an object so it might be confusing.

Using ME to refer workbooks or other can be tricky. you might wnat to consider properly refering workbook.

Regards.