Text to excel

[Ewright8]

I have 240 text files (dxdiag reports from 240 different computers) that I would like to put into an excel spreadsheet. I do not need all of the file but would like to have about nine different lines from the file placed in cells with one row representing each file (computer). Is this possible or does anyone have any suggestions how I may go about this without having to type all the data in manually.

 

[Ed Acosta]

I agree, but Ewright examples shows he wants each text going down in the column, I guess its easier to compare. 256 sounds about right, Dont know where I got 231 from, oh thats right that was my electric bill for last month

 

[Ewright8]

Rows is what i meant not columns, it has been a crazy day with the tornadoes and power outages. I ran the macro above and received a run-time error "62" input past end of file. I would like it in rows not columns, guess I should have said A1, B1, C1, D1 net file A2, B2, C2, D2. Thanks for all your help there's no way I would have figured this one out on my own.

 

[Ed Acosta]

Ok here is the code going down the Rows. The run-time error 62 is do to the trigger to end the loop did not happen. It looks for the first occurence of "Memory:" then it ends the loop to avoid searching the entire text file. One of the text file did not have "Memory:" label in it.

The new code will end when it finds "Memory:" or when it gets to the End of File which ever comes first. Draw back is that if any of the other labels are in the text file it will pull those in and overwrite the first pull. You can change "Memory:" in the Do statement to whatever trigger you want in the text file to end the loop.

Sub ShowFileList()
Dim fs, f, f1, fc, s
Dim LastRow As Long
Dim strPath As String
strPath = "C:\Data\" 'This is the Directory the files are located in
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(strPath)
Set fc = f.Files

Sheets(1).Select

For Each f1 In fc
If WorksheetFunction.CountA(Cells) > 0 Then LastRow = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1

Open strPath & f1.Name For Input As #1
Do Until InStr(1, INFO, "Memory:") Or EOF(1)
Line Input #1, INFO
If InStr(1, INFO, "Machine name:") Then Cells(LastRow, 1).Value = LTrim(INFO)
If InStr(1, INFO, "Operating System:") Then Cells(LastRow, 2).Value = LTrim(INFO)
If InStr(1, INFO, "Processor:") Then Cells(LastRow, 3).Value = LTrim(INFO)
If InStr(1, INFO, "Memory:") Then Cells(LastRow, 4).Value = LTrim(INFO)
Loop
Close #1
INFO = ""
Next

End Sub

 

[Ewright8]

<?xml:namespace prefix = v ns = "urn:schemas-microsoft-com:vml" /><v:shapetype id=_x0000_t75 stroked="f" filled="f" path="m@4@5l@4@11@9@11@9@5xe" oreferrelative="t" o:spt="75" coordsize="21600,21600"> Run Time Error '1004'</v:shapetype>
<v:shapetype stroked="f" filled="f" path="m@4@5l@4@11@9@11@9@5xe" oreferrelative="t" o:spt="75" coordsize="21600,21600">Application-defined or object-define error</v:shapetype>
<v:shapetype stroked="f" filled="f" path="m@4@5l@4@11@9@11@9@5xe" oreferrelative="t" o:spt="75" coordsize="21600,21600"></v:shapetype>
<v:shapetype stroked="f" filled="f" path="m@4@5l@4@11@9@11@9@5xe" oreferrelative="t" o:spt="75" coordsize="21600,21600">debug shows the following line highlighted</v:shapetype>
<v:shapetype stroked="f" filled="f" path="m@4@5l@4@11@9@11@9@5xe" oreferrelative="t" o:spt="75" coordsize="21600,21600"></v:shapetype>
<v:shapetype stroked="f" filled="f" path="m@4@5l@4@11@9@11@9@5xe" oreferrelative="t" o:spt="75" coordsize="21600,21600">If InStr(1, INFO, "Machine name:") Then Cells(LastRow, 1).Value = LTrim(INFO)<v:stroke joinstyle="miter"></v:stroke><v:formulas><v:f eqn="if lineDrawn pixelLineWidth 0"></v:f><v:f eqn="sum @0 1 0"></v:f><v:f eqn="sum 0 0 @1"></v:f><v:f eqn="prod @2 1 2"></v:f><v:f eqn="prod @3 21600 pixelWidth"></v:f><v:f eqn="prod @3 21600 pixelHeight"></v:f><v:f eqn="sum @0 0 1"></v:f><v:f eqn="prod @6 1 2"></v:f><v:f eqn="prod @7 21600 pixelWidth"></v:f><v:f eqn="sum @8 21600 0"></v:f><v:f eqn="prod @7 21600 pixelHeight"></v:f><v:f eqn="sum @10 21600 0"></v:f></v:formulas><vath o:connecttype="rect" gradientshapeok="t" o:extrusionok="f"></vath><?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o:lock aspectratio="t" v:ext="edit"></o:lock></v:shapetype>

<v:shapetype id=_x0000_t75 stroked="f" filled="f" path="m@4@5l@4@11@9@11@9@5xe" oreferrelative="t" o:spt="75" coordsize="21600,21600"> </v:shapetype>

 

[Norie]

This, adapted from Ed's code, seems to work for me.

Sub ListDX()
Dim rng As Range
Dim fs, f, f1, fc, s
Dim LastRow As Long
Dim strPath As String
strPath = "C:\DX\" 'This is the Directory the files are located in
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(strPath)
Set fc = f.Files
    Set rng = Worksheets(1).Range("A2")
    
    rng.Offset(-1).Resize(, 4).Value = Array("Machine name", "Operating System", "Processor", "Memory")
    
    For Each f1 In fc
    
        Open strPath & f1.Name For Input As #1
            Do Until InStr(info, "Memory:")
                
                Line Input #1, info
                
                x = Split(info, ":")
                
                If Trim(x(0)) = "Machine name" Then rng.Value = Trim(x(1))
                If Trim(x(0)) = "Operating System" Then rng.Offset(, 1).Value = Trim(x(1))
                If Trim(x(0)) = "Processor" Then rng.Offset(, 2).Value = Trim(x(1))
                If Trim(x(0)) = "Memory" Then rng.Offset(, 3).Value = Trim(x(1))
                
            Loop
        Close #1
        info = ""
        
        Set rng = rng.Offset(1)
    
    Next
End Sub

 

[Ewright8]

Received error '62
Input past end of file

debug stops at

Line Input #1, info

 

[Norie]

Could you please give us some more information/feedback?

We are basically running on assumptions here.

Apart from the latest error does the code work at all? ie does it work up to a point.

Oh and do you have these files, and only these files, in the folder?

 

[Ewright8]

I entered the following code and it seems to work but I am sure it is not coded the way that it should be and it puts a couple of lines at the beginning of the spreadsheet that I have to remove. Any suggestions would be greatly appreciated.

Sub ShowFileList()
Dim fs, f, f1, fc, s
Dim LastRow As Long
Dim LastCol As Long
Dim strPath As String
strPath = "C:\Data\" 'This is the Directory the files are located in
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(strPath)
Set fc = f.Files
Sheets(1).Select
If WorksheetFunction.CountA(Cells) > 0 Then 'Search for any entry, by searching backwards by Rows.
LastRow = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End If

For Each f1 In fc
Open strPath & f1.Name For Input As #1
Do Until EOF(1)
Line Input #1, INFO
If InStr(1, INFO, "Machine name:") Then LastRow = LastRow + 1: Cells(LastRow, 1).Value = INFO 'This is where you would examine the line for what you are looking for
Loop
Close #1
Open strPath & f1.Name For Input As #1
Do Until EOF(1)
Line Input #1, INFO
If InStr(1, INFO, "Operating System:") Then LastRow = LastRow: Cells(LastRow, 2).Value = INFO 'This is where you would examine the line for what you are looking for
Loop
Close #1
Open strPath & f1.Name For Input As #1
Do Until EOF(1)
Line Input #1, INFO
If InStr(1, INFO, "Processor:") Then LastRow = LastRow: Cells(LastRow, 3).Value = INFO 'This is where you would examine the line for what you are looking for
Loop
Close #1
Open strPath & f1.Name For Input As #1
Do Until EOF(1)
Line Input #1, INFO
If InStr(1, INFO, " Memory:") Then LastRow = LastRow: Cells(LastRow, 4).Value = INFO 'This is where you would examine the line for what you are looking for
Loop
Close #1
Open strPath & f1.Name For Input As #1
Do Until EOF(1)
Line Input #1, INFO
If InStr(1, INFO, "Card name:") Then LastRow = LastRow: Cells(LastRow, 5).Value = INFO 'This is where you would examine the line for what you are looking for
Loop
Close #1
Open strPath & f1.Name For Input As #1
Do Until EOF(1)
Line Input #1, INFO
If InStr(1, INFO, "Description:") Then LastRow = LastRow: Cells(LastRow, 6).Value = INFO 'This is where you would examine the line for what you are looking for
Loop
Close #1
Next

End Sub

 

[Norie]

Why are you using that code?

Where did it come from? I certainly didn't post anything like that.

And if that's the code causing the error I can think of a few reasons why it might.

The first one being opening the same file 6 times.

Did you actually try the code posted? Without alteration?

 

[Ewright8]

That was one from previously that was modified and was the first one that I got to work. I just got your working, somehow when I cut and pasted it changed jsut a little bit and when I looked at the file I made the changes and it worked. To add two more fields is this correct or is it wrong, I want to add card and description.

Sub ListDX()
Dim rng As Range
Dim fs, f, f1, fc, s
Dim LastRow As Long
Dim strPath As String
strPath = "C:\DX\" 'This is the Directory the files are located in
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(strPath)
Set fc = f.Files
Set rng = Worksheets(1).Range("A2")

rng.Offset(-1).Resize(, 6).Value = Array("Machine name", "Operating System", "Processor", "Memory", "Card name", "Description")

For Each f1 In fc

Open strPath & f1.Name For Input As #1
Do Until InStr(info, "Description:")

Line Input #1, info

x = Split(info, ":")

If Trim(x(0)) = "Machine name" Then rng.Value = Trim(x(1))
If Trim(x(0)) = "Operating System" Then rng.Offset(, 1).Value = Trim(x(1))
If Trim(x(0)) = "Processor" Then rng.Offset(, 2).Value = Trim(x(1))
If Trim(x(0)) = "Memory" Then rng.Offset(, 3).Value = Trim(x(1))
If Trim(x(0)) = "Card name" Then rng.Offset(, 4).Value = Trim(x(1))
If Trim(x(0)) = "Description" Then rng.Offset(, 5).Value = Trim(x(1))

Loop
Close #1
info = ""

Set rng = rng.Offset(1)

Next
End Sub


Thanks, this is the closest I have been so far.