[VBA] Copying data from Excel to .txt File

[Gordon85]

Hello

I am trying to make VBA to copy data from Excel to .txt file.
The problem is that I am not quite sure of 2 things

1) How to define the range so that VBA should know to take a specific range for each Car make (for the first Car make the range was initiated manually). So I think the condition would be something like: If(Car make==same as Car make from rows below), then do a minimum on Mileage for that range, and this should be done for each Car make.
.
2) How to make the code more efficient rather than declaring a lot of variables. As there would be hundreds of entries (multiple Car makes, and after each make the lowest Mileage should be displayed). As what has been done so far for rows 2-3 should also be done for rows 4-7, and so on... But for the sake of the example I kept it short.


Below you'll find attached the Workbook (the code is located in Module1), as well as the expected Answers in the .txt file.

I would be more than grateful if someone could help me out with it.

Many thanks, I appreciate it!

Gordon

[Gordon85]

I've also attached the [CODE] below:
Any help would be more than appreciated. Thank you in advance!

Sub Copytotxt()
Open ThisWorkbook.Path & "\Test.txt" For Output As #1
Print #1, "AUTO"

Dim SrchRng As Range, cel1 As Range
Set SrchRng = ActiveWorkbook.ActiveSheet.Range("A1:Z10")
For Each cel1 In SrchRng
    If InStr(cel1.Value, "Car") > 0 Then
 Print #1, "CAR MAKE&MODEL:"; cel1.Offset(1, 0).Value;
 End If

     If InStr(cel1.Value, "Date") > 0 Then
     Print #1, vbCrLf; cel1.Offset(1, 0).Value; " Date + Rent & Return Days : "; cel1.Offset(1, 1).Value; cel1.Offset(1, 2);
   End If


Next cel1


For Each cel2 In SrchRng
    If InStr(cel2.Value, "Car") > 0 Then
    Print #1, vbCrLf;
 Print #1, "CAR MAKE&MODEL:"; cel2.Offset(2, 0).Value;
 End If

     If InStr(cel2.Value, "Date") > 0 Then
     Print #1, vbCrLf; cel2.Offset(2, 0).Value; " Date + Rent & Return Days : "; cel2.Offset(2, 1).Value; cel2.Offset(2, 2);
   End If
     If InStr(cel2.Value, "Mileage") > 0 Then
     Dim rng As Range
Dim dblMin As Double
'VBA should know where to take the range from, in this case E2:E3 was inputted manually.
'The criteria would be that the Range should start and end on the beginning and end of each car make.
Set rng = ActiveSheet.Range("E2:E3")
'The criteria would be that the Range should start and end on the beginning and end of each car make.
dblMin = Application.WorksheetFunction.Min(rng)

     
     Print #1, vbCrLf; "Lowest Mileage is:"; dblMin;
   End If

Next cel2



Print #1, strContent
Close #1
End Sub

The answers should be:

AUTO
CAR MAKE&MODEL:Audi A4
01.01.2000 Date + Rent & Return Days : MondayFriday
CAR MAKE&MODEL:Audi A4
11.04.2000 Date + Rent & Return Days : TuesdayFriday
Lowest Mileage is: 1200
CAR MAKE&MODEL:BMW 320D
05.05.2010 Date + Rent & Return Days : MondaySunday
CAR MAKE&MODEL:BMW 320D
02.01.2010 Date + Rent & Return Days : ThursdaySaturday
CAR MAKE&MODEL:BMW 320D
01.01.2009 Date + Rent & Return Days : FridaySunday
CAR MAKE&MODEL:BMW 320D
05.08.2012 Date + Rent & Return Days : MondayWednesday
Lowest Mileage is: 1532

Here is how the Excel looks like:
Capture.JPG
Please note that there can be hundreds of entries, this example has few entries.

[Eastw00d]

Hi Gordon85,
I came up with this solution, but only 1 condition has to be met: column A, the cars, has to be sorted (alfabetically):

Option Explicit
Sub WriteFile()
    Dim Line As String
    Dim LineValues() As Variant
    Dim OutputFileNum As Integer
    Dim PathName As String
    Dim RowNum As Integer
    Dim lro As Long, lco As Long
    Dim rng As Range
    Dim Mile As Long
    
    PathName = "C:\Temp"
    PathName = InputBox("Where do you want to place the file? ", Default:=PathName)
    
    OutputFileNum = FreeFile
    
    Open PathName & "\Test.txt" For Output Lock Write As #OutputFileNum
    Line = "AUTO"
    Print #OutputFileNum, Line
    
    With Worksheets("Sheet1")
        Set rng = .[A2].CurrentRegion
        lro = rng.Rows.Count
        lco = rng.Columns.Count

        ReDim LineValues(1 To lco)
        Mile = 0
        For RowNum = 2 To lro
            LineValues(1) = "Car Make & Model: " & Cells(RowNum, 1) & vbCrLf
            LineValues(2) = Cells(RowNum, 2) & " "
            LineValues(3) = "Date + Rent & Return Days : " & Cells(RowNum, 3) & Cells(RowNum, 4)
            
            If Cells(RowNum, 1) <> Cells(RowNum - 1, 1) Then 'determine new carmileage
                Mile = Cells(RowNum, 5)
            Else
                If Cells(RowNum, 5) < Mile Then Mile = Cells(RowNum, 5)
            End If
            
            If Cells(RowNum, 1) <> Cells(RowNum + 1, 1) Then 'determine when to print
                LineValues(4) = vbCrLf & "Lowest Mileage is: " & Mile
            Else
                LineValues(4) = ""
            End If
            
            Line = Join(LineValues, "")
            Print #OutputFileNum, Line
        Next RowNum
    End With
    Close OutputFileNum
End Sub

Cheers
Erwin

[Gordon85]

Hello Erwin,

That works like a charm (Rep+). The only problem would be that the Code is targeting specific columns, can this be tweaked to look for specific keywords as I tried above in post #2?

I am asking because there will be more than 1 Excel document, and the names of the column headers might vary, that's why I used the search function for specific keywords combined with Active Sheet, because I am trying to run the VBA Code from an External .xlsm file to target different .xlsx files.

Thank you!
Gordon

[Eastw00d]

Sure, look, everything in Cells can be changed, as it is defined as Cells(RowNum, Colnum), and I have fixed the latter.
That can be changed of course
I think you know enough VBA to do it yourself, otherwise we can help you

Cheers
Erwin

[jindon]

try

Sub test()
    Dim myList, a, e, i As Long, temp As String, dic As Object
    Dim wf As WorksheetFunction, ap As Application
    Set wf = WorksheetFunction: Set ap = Application
    myList = Array("Car*", "Date*", "Rent*", "Return*", "Mileage*")  '<--- alter to site
    With Sheets("sheet1").Cells(1).CurrentRegion
        a = Filter(wf.IfError(ap.Match(myList, .Rows(1), 0), False), False, 0)
        If UBound(a) <> UBound(myList) Then
            MsgBox "Something wrong in Header", vbCritical
            Exit Sub
        End If
        a = ap.Index(.Value, Evaluate("row(1:" & .Rows.Count & ")"), a)
        Set dic = CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            temp = Join(Array("Car Make & Model", a(i, 1)), ":")
            temp = Join(Array(temp, Join(Array(a(i, 2), "Date + Rent & " & _
                   "Return Days : " & a(i, 3) & a(i, 4)))), vbCrLf)
            If Not dic.exists(a(i, 1)) Then
                dic(a(i, 1)) = Array(temp, a(i, 5))
            Else
                dic(a(i, 1)) = Array(Join(Array(dic(a(i, 1))(0), temp), _
                               vbCrLf), ap.Min(dic(a(i, 1))(1), a(i, 5)))
            End If
        Next
        For Each e In dic
            dic(e) = dic(e)(0) & vbCrLf & "Lowest Mileage is: " & dic(e)(1)
        Next
        Open ThisWorkbook.Path & "/Answer.txt" For Output As #1
            Print #1, Join(Array("AUTO", Join(dic.items, vbCrLf)), vbCrLf);
        Close #1
    End With
End Sub

[Gordon85]

Thank you as well, interesting approach! Rep+

By the way, would there also be a way to get the Date where the minimum Mileage appears and put it on the same line with the Lowest Mileage?

Sort of like:

Date associated with lowest Mileage, "Lowest mileage is", Lowest Mileage value

I tried putting " " between the Car make, but silly me got it wrong I guess

 temp = Join(Array("Car Make & Model", ""a(i, 1))"", ":")

Should have outputted :Car Make & Model:"Audi A4" for example, any idea why it doesen't work?

Thank you!
Gordon

[jindon]

1) Please don't quote whole posts -- it's just clutter.*If you are responding to a post out of sequence, limit quoted content to a few relevant lines that makes clear to whom and what you are responding

2) Not sure, but something like this maybe...

Sub test()
    Dim myList, a, e, i As Long, temp As String, dic As Object
    Dim wf As WorksheetFunction, ap As Application, flg As Boolean
    Set wf = WorksheetFunction: Set ap = Application
    myList = Array("Car*", "Date*", "Rent*", "Return*", "Mileage*")
    With Sheets("sheet1").Cells(1).CurrentRegion
        a = Filter(wf.IfError(ap.Match(myList, .Rows(1), 0), False), False, 0)
        If UBound(a) <> UBound(myList) Then
            MsgBox "Something wrong in Header", vbCritical
            Exit Sub
        End If
        a = ap.Index(.Value, Evaluate("row(1:" & .Rows.Count & ")"), a)
        Set dic = CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            temp = Join(Array("Car Make & Model", """" & a(i, 1) & """"), ":")
            temp = Join(Array(temp, Join(Array(a(i, 2), "Date + Rent & " & _
                   "Return Days : " & a(i, 3) & a(i, 4)))), vbCrLf)
            If Not dic.exists(a(i, 1)) Then
                dic(a(i, 1)) = Array(temp, a(i, 2), a(i, 5))
            Else
                flg = a(i, 5) < dic(a(i, 1))(2)
                dic(a(i, 1)) = Array(Join(Array(dic(a(i, 1))(0), temp), vbCrLf), _
                 IIf(flg, a(i, 2), dic(a(i, 1))(1)), IIf(flg, a(i, 5), dic(a(i, 1))(2)))
            End If
        Next
        For Each e In dic
            dic(e) = dic(e)(0) & vbCrLf & "Lowest Mileage is: " & dic(e)(2) & " on " & dic(e)(1)
            ' dic(e)(2) = lowest mileage, dic(e)(1) = corresponding date
        Next
        Open ThisWorkbook.Path & "/Answer.txt" For Output As #1
            Print #1, Join(Array("AUTO", Join(dic.items, vbCrLf)), vbCrLf);
        Close #1
    End With
End Sub

[Gordon85]

Thank you!

[QUOTE=jindon;5300224]1) Please don't quote whole posts -- it's just clutter.*If you are responding to a post out of sequence, limit quoted content to a few relevant lines that makes clear to whom and what you are responding

2) Not sure, but something like this maybe...

[Marc L]

According to the initial attachment and posts #1, 4 & 7 an easy VBA starter demonstration (edit v3) :

Sub Demo1()
      Const S = " Lowest Mileage is :"
        Dim V, C, H, W, F%, R&
            V = [{"Car*","Date*","Rent*","Return*","Mile*"}]
    With Sheet1.UsedRange.Rows
            C = Application.Match(V, .Item(1), 0):  If Application.Count(C) < UBound(V) Then Beep: Exit Sub
           .Sort .Cells(C(1)), xlAscending, Header:=xlYes
            H = Array(.Cells(C(1)) & " : """, """" & vbNewLine)
            W = Application.Index(.Item(2), , C)
            F = FreeFile
            Open ThisWorkbook.Path & Application.PathSeparator & "Answers .txt" For Output As #F
            Print #F, "AUTO"
        For R = 2 To .Count
            V = Application.Index(.Item(R), , C)
            If V(1) <> W(1) Then Print #F, W(2); S; W(5): W = V Else If V(5) < W(5) Then W = V
            Print #F, H(0); V(1); H(1); V(2); " Date + Rent & Return Days : "; V(3); " "; V(4)
        Next
    End With
            Print #F, W(2); S; W(5)
            Close #F
End Sub 

[Gordon85]

Thank you, this works as well!
Rep+

[INDENT]
According to the initial attachment and posts #1, 4 & 7 an easy VBA starter demonstration :

[Marc L]

Post #9 just edited : car model double quotes added …

Thanks for the rep' !

[Marc L]

New edit in post #9 :

• Resolves the sort issue if the car model is not the first column …
  
  
• May increase the speed for hundreds / thousands source rows.
  As the more rows, the slower Index worksheet function.
  So it's faster to use Index with a row at a time - like to not play with huge strings - and the code is a bit simplified …

[Gordon85]

Thank you Marc L!

Appreciated!

[Gordon85]

Guys, would be there any other way when copying the data from the Excel to the .txt file, to have just 1 appearance of the Car name and introduce another keyword such as color where the date would also be printed?

For example if there is something like this in the Excel file
Capture.JPG



To output something like this?

Car make & model "BMW 320D"
05.05.2010 Rent+Return Monday Sunday
02.01.2010 Rent+Return Thursday Saturday
01.01.2009 Rent+Return Friday Sunday
01.01.2009 Lowest mileage is 1532
05.05.2010 Color Red
02.01.2010 Color Green
01.01.2009 Color Blue
Car make & model "Audi A4"
02.01.2020 Rent+Return Wednesday Saturday
04.02.2011 Rent+Return Monday Thursday
02.01.2020 Lowest mileage is 2312
02.01.2020 Color Yellow
04.02.2011 Color Pink
Car make & model "Audi A5"
02.03.2008 Rent+Return Friday Saturday
02.03.2008 Lowest mileage is 123124
02.03.2008 Color Orange


Many thanks!
Gordon

[Marc L]

With such weird text export format maybe I will wait until the rules will be definitively fixed according to a new attachment
as it's the third time you modify them …

[Gordon85]

Hi,

Sorry about that.
Just modified. I hope it is clear.
I didn't realize that the formatting would be compromised.


Thank you!
Gordon

[Marc L]

You forgot the source data workbook but is it the last change, that's the question ?
Or it's better to wait until all your final export format will be well known …

[Gordon85]

You forgot the source data workbook but is it the last change, that's the question ?
Or it's better to wait until all your final export format will be well known …

Hello, my apologies, I didn't see this (old and senile).
Yes, it is the final form, I added everything. The request would be that the Car make not to repeat itself for the same car make.
Many thanks.
Gordon

[Gordon85]

Added that as well, thank you for reminding. Sorry about that, I thought the copy-paste would do.
That's the woozie of being old.

[jindon]

Sub test()
    Dim myList, a, e, i As Long, temp As String, txt As String, dic As Object
    Dim wf As WorksheetFunction, ap As Application, flg As Boolean
    Set wf = WorksheetFunction: Set ap = Application
    myList = Array("Car*", "Date*", "Rent*", "Return*", "Mileage*", "Color*")
    With Sheets("sheet1").Cells(1).CurrentRegion
        a = Filter(wf.IfError(ap.Match(myList, .Rows(1), 0), False), False, 0)
        If UBound(a) <> UBound(myList) Then
            MsgBox "Something wrong in Header", vbCritical
            Exit Sub
        End If
        a = ap.Index(.Value, Evaluate("row(1:" & .Rows.Count & ")"), a)
        Set dic = CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            temp = Join(Array(Join(Array(a(i, 2), "Date + Rent & " & _
                   "Return Days : " & a(i, 3) & a(i, 4)))), vbCrLf)
            txt = Join(Array(a(i, 2), "Color", a(i, 6)))
            If Not dic.exists(a(i, 1)) Then
                dic(a(i, 1)) = Array(temp, a(i, 2), a(i, 5), txt)
            Else
                flg = a(i, 5) < dic(a(i, 1))(2)
                dic(a(i, 1)) = Array(Join(Array(dic(a(i, 1))(0), temp), vbCrLf), _
                IIf(flg, a(i, 2), dic(a(i, 1))(1)), IIf(flg, a(i, 5), dic(a(i, 1))(2)), _
                Join(Array(dic(a(i, 1))(3), txt), vbCrLf))
            End If
        Next
        For Each e In dic
            dic(e) = Join(Array("Car Make & Model """ & e & """", dic(e)(0), _
            "Lowest Mileage is: " & dic(e)(2) & " on " & dic(e)(1), dic(e)(3)), vbCrLf)
        Next
        Open ThisWorkbook.Path & "/Answer.txt" For Output As #1
            Print #1, Join(Array("AUTO", Join(dic.items, vbCrLf)), vbCrLf);
        Close #1
    End With
End Sub

[Marc L]

Second question to answer - so I expect for two answers - :

do you need the initial order must be respected as it is - meaning the car model column is yet & well sorted -
or for 'safety' it's better to sort the column like my post #9 demonstration does ?

[Gordon85]

Thank you Jindon!

Marc L,

1) Initial order won't be respected as it is.
2) I would say yes, it would be better as in post #9 for "safety" reasons, as the order would be randomly.

[Marc L]

As my first question is in post #18 …

[Marc L]

So according to the last attachment the final version :

Sub Demo2()
      Const D = """", S = " Lowest Mileage is : "
        Dim V, C, H$, W, F%, R&, T$
            V = [{"Car*","Date*","Rent*","Return*","Mile*","Color*"}]
    With Sheet1.UsedRange.Rows
            C = Application.Match(V, .Item(1), 0):  If Application.Count(C) < UBound(V) Then Beep: Exit Sub
           .Sort .Cells(C(1)), xlAscending, Header:=xlYes
            H = .Cells(C(1)) & " """
            W = Application.Index(.Item(2), , C)
            F = FreeFile
            Open ThisWorkbook.Path & Application.PathSeparator & "Answers .txt" For Output As #F
            Print #F, "AUTO"; vbNewLine; H; W(1); D
        For R = 2 To .Count
            V = Application.Index(.Item(R), , C)
            If V(1) <> W(1) Then Print #F, W(2); S & W(5); T; vbNewLine; H; V(1); D: T = "": W = V _
                            Else If V(5) < W(5) Then W = V
            Print #F, V(2); " Rent+Return "; V(3); " "; V(4)
            T = T & vbNewLine & V(2) & " Color " & V(6)
        Next
    End With
            Print #F, W(2); S & W(5); T;
            Close #F
End Sub 

Do you like it ? So thanks to click on bottom left star icon « ★ Add Reputation » !

[Gordon85]

Thank you, Rep+