Export to csv based upon date/time criteria

[haloway13]

I have an excel worksheet that I need to export to .csv file. Column A has increasing timestamps. I need to limit the rows exported to a daterange.

7/15/2010 15:25:34 is the typical date/time

Each row has several columns of data associated with that datetime.

If at all possible it would be great to have it in the form of a function that would take the sheetname, column that has the criteria to be checked ,the string of the daterange that would be acceptable and outputfilename.

Thank you in advance!

Tim

[Kenneth Hobs]

Welcome to the forum!

It should not be difficult. If you can make a very simple example workbook and post it, an on-target solution will soon follow.

[mancubus]

try


Sub makeCSV()

Dim wb As Workbook, ws As Worksheet
Dim csvRange As Range
Dim xpwsName As String, xpFile As String
Dim LR As Long, LC As Long
Dim fltCrit, fltCol As Integer

Set wb = ThisWorkbook 'change to suit
Set ws = wb.Worksheets("toCSV") 'change to suit

With ws
LR = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
LC = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
Set csvRange = .Range(.Cells(1, 1), .Cells(LR, LC))
End With

xpwsName = ws.Name
fltCrit = "7/15/2010 15:25:34" 'change to suit
fltCol = 1 'change to suit
xpFile = "C:\Users\me\Documents\test\mycsvfile.csv" 'change to suit

ExportRangeCSV xpwsName, csvRange, fltCrit, fltCol, xpFile

End Sub


Sub ExportRangetoCSV(xpWS As String, xpRng As Range, fCrit As Variant, Col As Integer, csvFile As String)

If Worksheets(xpWS).AutoFilterMode = True Then Worksheets(xpWS).AutoFilterMode = False
Worksheets(xpWS).Range("A1").AutoFilter Field:=Col, Criteria1:="=" & fCrit

Set xpRng = Worksheets(xpWS).AutoFilter.Range

xpRng.Copy
Workbooks.Add xlWBATWorksheet
Range("A1").PasteSpecial xlPasteValuesAndNumberFormats

Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=csvFile, FileFormat:=xlCSV
ActiveWorkbook.Close
Application.DisplayAlerts = True

Application.CutCopyMode = False

End Sub

[mancubus]

http://www.erlandsendata.no/english/index.php?d=envbatextexportcsv



Sub xport2CSV()

Dim wb As Workbook, ws As Worksheet
Dim xpRange As Range
Dim xpwbName As String, xpwsName As String
Dim xpFile As String, xpRngAdr As String
Dim LR As Long, LC As Long
Dim fltCrit, fltCol As Integer

Set wb = ThisWorkbook 'change to suit
Set ws = wb.Worksheets("toCSV") 'change to suit

With ws
LR = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
LC = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
Set xpRange = .Range(.Cells(1, 1), .Cells(LR, LC))
End With

xpFile = "C:\Users\me\Documents\test\DelimitedText.csv" 'change to suit
xpwbName = wb.Name
xpwsName = ws.Name
xpRngAdr = xpRange.Address
fltCrit = "7/15/2010 15:25:34" 'change to suit
fltCol = 1 'change to suit

ExportRangeAsDelimitedText xpwbName, xpwsName, xpRngAdr, _
fltCrit, fltCol, xpFile, ";", _
True, True, False

End Sub

Sub ExportRangeAsDelimitedText(SourceWB As String, SourceWS As String, SourceAddress As String, _
fCrit As Variant, Col As Integer, TargetFile As String, SepChar As String, _
SaveValues As Boolean, ExportLocalFormulas As Boolean, AppendToFile As Boolean)
'http://www.erlandsendata.no/english/index.php?d=envbatextexportcsv

Dim SourceRange As Range, SC As String * 1
Dim A As Integer, r As Long, c As Integer, totr As Long, pror As Long
Dim fn As Integer, LineString As String, tLine As String
' validate the input data if necessary
Workbooks(SourceWB).Activate
Worksheets(SourceWS).Activate
If Application.WorksheetFunction.CountA(Range(SourceAddress)) = 0 Then Exit Sub
If Not AppendToFile Then
If Dir(TargetFile) <> "" Then
On Error Resume Next
Kill TargetFile
On Error GoTo 0
If Dir(TargetFile) <> "" Then
MsgBox TargetFile & _
" already exists, rename, move or delete the file before you try again.", _
vbInformation, "Export range to textfile"
Exit Sub
End If
End If
End If
If UCase(SepChar) = "TAB" Or UCase(SepChar) = "T" Then
SC = Chr(9)
Else
SC = Left(SepChar, 1)
End If

' perform export
If Worksheets(SourceWS).AutoFilterMode = True Then Worksheets(SourceWS).AutoFilterMode = False
Set SourceRange = Range(SourceAddress)
Worksheets(SourceWS).Range("A1").AutoFilter Field:=Col, Criteria1:="=" & fCrit
Set SourceRange = Worksheets(SourceWS).AutoFilter.Range

On Error GoTo NotAbleToExport
fn = FreeFile
Open TargetFile For Append As #fn ' open textfile for new input
On Error GoTo 0
' determine the total number of rows to process
totr = 0
For A = 1 To SourceRange.Areas.Count
totr = totr + SourceRange.Areas(A).Rows.Count
Next A
' start writing the character-separated textfile
pror = 0
For A = 1 To SourceRange.Areas.Count
For r = 1 To SourceRange.Areas(A).Rows.Count
LineString = ""
For c = 1 To SourceRange.Areas(A).Columns.Count
tLine = ""
On Error Resume Next
If SaveValues Then
tLine = SourceRange.Areas(A).Cells(r, c).Value
Else
If ExportLocalFormulas Then
tLine = SourceRange.Areas(A).Cells(r, c).FormulaLocal
Else
tLine = SourceRange.Areas(A).Cells(r, c).Formula
End If
End If
On Error GoTo 0
LineString = LineString & tLine & SC
Next c
pror = pror + 1
If pror Mod 50 = 0 Then
Application.StatusBar = "Writing delimited textfile " & _
Format(pror / totr, "0 %") & "..."
End If
If Len(LineString) > 1 Then LineString = Left(LineString, Len(LineString) - 1)
If LineString = "" Then
Print #fn,
Else
Print #fn, LineString
End If
Next r
Next A
Close #fn ' close the textfile
NotAbleToExport:
If Worksheets(SourceWS).AutoFilterMode = True Then Worksheets(SourceWS).AutoFilterMode = False
Set SourceRange = Nothing
Application.StatusBar = False

End Sub

[haloway13]

Thank you so much, these will come in handy.