PDA

View Full Version : [SOLVED] Import Text Content From File - Stored in SubFolders - If It Matches File Name Col A



dj44
11-19-2016, 03:37 AM
Hi folks,

Good Saturday to all.:):)

Last week good man Kenneth was very kind to help me with this great piece of code that did this job.

I put the file name in Column A and in Column B it imported the content of that file like magic.

It is doing a STELLAR job and I am really happy with it.

Seeing that I depend on it so much now, I need to ask if someone can be kind enough to help me adapt it just 1 step further.

It currently imports only from the current workbook folder location.

I believe i need a recursion search?




Private Sub Worksheet_Change(ByVal Target As Range)

' Kenneth Annotated Version
'http://www.vbaexpress.com/forum/showthread.php?57674-Search-Matched-File-Names-in-Col-A-Import-the-Text-in-Col-B

Dim C As Range, r As Range, txtPath As String
Dim oTextImport As Range, oFileName As String, oFileNameTXT As String
Dim glb_origCalculationMode As Integer, fso As Object

On Error GoTo EndSub
glb_origCalculationMode = Application.Calculation
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Cursor = xlWait
.StatusBar = "Adding txt file contents..."
.EnableCancelKey = xlErrorHandler
End With

Set r = Intersect(Target, Columns("A"))
If r Is Nothing Then Exit Sub

Set fso = CreateObject("Scripting.FileSystemObject")

txtPath = ThisWorkbook.Path & "\" 'Path to .txt files with trailing \.
'If Not fso.FileExists(txtPath) Then Exit Sub

For Each C In r
Set oTextImport = C.Offset(, 1)
oFileName = C.Value
oFileNameTXT = txtPath & oFileName & ".txt"



Select Case True
Case oFileName = ""
oTextImport.Value = ""


Case fso.FileExists(oFileNameTXT)
With oTextImport
.Value = fso.GetFile(oFileNameTXT).OpenAsTextStream(1, -2).ReadAll
'.Value = Replace(fso.GetFile(oFileNameTXT).OpenAsTextStream(1, -2).ReadAll, vbCrLf, vbLf)
.WrapText = True
Columns(.Column).EntireColumn.AutoFit
Rows(.Row).EntireRow.AutoFit
End With
Range(C, oTextImport).VerticalAlignment = xlCenter
Case Else
End Select
Next C

EndSub:
With Application
.Calculation = glb_origCalculationMode
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.CalculateBeforeSave = True
.Cursor = xlDefault
.StatusBar = False
.EnableCancelKey = xlInterrupt
End With
Set fso = Nothing


End Sub



I have found many functions for looping through subfolders on the net, but I have no clue how to actulaly use it or embed it within Kenneths code, and I did some things that broke it so - I don’t want to ruin the code.

I found a subfolder loop on this thread as well
I have scoured the whole internet for days and what I found has not been able to help me as I have mixed and matched the code and got myself in a pickle.

http://www.excelguru.ca/forums/showthread.php?462-Help-with-hyperlinking-files-in-subdirectories-to-a-list-of-filenames-in-another-work

If a pro has some spare time and wouldn’t mind advising me on how I can access a text file that may be stored in a subfolder I would be really grateful.


Thank you very much for looking at this, and I am very grateful for your time

Kenneth Hobs
11-19-2016, 06:24 AM
Did you want the parent folder to be that workbook's folder?

dj44
11-19-2016, 07:05 AM
Hello Kenneth,

Nice to see you again, I hope I'm not disturbing your weekend.

The code is working really good :)

17652


But then I found I had text files in these nested folders,:doh::doh: so I got to work thinking I could change some bits and bobs, but nothing worked out sadly.

If I enter Textfile8 in Column A -
Does it have the power to do exactly what its doing now import the content ?

That would solve the biggest problem ever - as I have to manually go into the folder and look it up - and search for it.

I hope its not too much trouble or more work, if this is a possibility

Thank you :)

Kenneth Hobs
11-19-2016, 09:51 AM
Be sure to test on backup files and backup/save your main file prior to doing many changes to Column A.

The main two concepts used here are the use of the command shell's Dir method and Filter(). You can delete the test sub if you like. I just included it to quickly illustrate how to use the two concepts more simply.

When the macro runs that first part, you might see a slight screen flicker. I can show you an FSO way if that bothers you too much. Put this routine into a Module:

Sub Test()
Dim a() As Variant, b() As String
a() = aFFs(ThisWorkbook.Path & "\*.txt", , True)
Debug.Print UBound(a), a(0)
'https://msdn.microsoft.com/en-us/library/office/gg278418(v=office.15).aspx
b() = Filter(a(), "\Raw_data.txt", True, vbTextCompare)
Debug.Print UBound(b)
If UBound(b) <> -1 Then Debug.Print b(0)
End Sub


'Set extraSwitches, e.g. "/ad", to search folders only.
'MyDir should end in a "\" character unless searching by wildcards, e.g. "x:\test\t*
'Command line switches for the shell's Dir, http://ss64.com/nt/dir.html
Function aFFs(myDir As String, Optional extraSwitches = "", _
Optional tfSubFolders As Boolean = False) As Variant

Dim s As String, a() As String, v As Variant
Dim b() As Variant, i As Long

If tfSubFolders Then
s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & myDir & """" & " /b /s " & extraSwitches).StdOut.ReadAll
Else
s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & myDir & """" & " /b " & extraSwitches).StdOut.ReadAll
End If

a() = Split(s, vbCrLf)
If UBound(a) = -1 Then
Debug.Print myDir & " not found.", vbCritical, "Macro Ending"
Exit Function
End If
ReDim Preserve a(0 To UBound(a) - 1) As String 'Trim trailing vblfcr

For i = 0 To UBound(a)
If Not tfSubFolders Then
s = Left$(myDir, InStrRev(myDir, "\"))
'add the folder name
a(i) = s & a(i)
End If
Next i
aFFs = sA1dtovA1d(a)
End Function


Function sA1dtovA1d(strArray() As String) As Variant
Dim varArray() As Variant, i As Long
ReDim varArray(LBound(strArray) To UBound(strArray))
For i = LBound(strArray) To UBound(strArray)
varArray(i) = CVar(strArray(i))
Next i
sA1dtovA1d = varArray()
End Function



As before, put this routine into your Sheet object. Replace the existing Sub using the Change event in the sheet object with this one.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range, r As Range, txtPath As String
Dim hCell As Range, fn As String, fnTXT As String
Dim glb_origCalculationMode As Integer, fso As Object
Dim a() As Variant, b() As String

On Error GoTo EndSub
glb_origCalculationMode = Application.Calculation
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Cursor = xlWait
.StatusBar = "Adding txt file contents..."
.EnableCancelKey = xlErrorHandler
End With

Set r = Intersect(Target, Columns("A"))
If r Is Nothing Then Exit Sub

Set fso = CreateObject("Scripting.FileSystemObject")

txtPath = ThisWorkbook.Path & "\" 'Path to .txt files with trailing \.
'If Not fso.FileExists(txtPath) Then Exit Sub

'Put subfolder *.txt files into array a(). Macro ends if not files found.
a() = aFFs(txtPath & "*.txt", , True)

For Each c In r
Set hCell = c.Offset(, 1)
fn = c.Value


'Find the first file in a(), if any.
fnTXT = ""
If c.Value <> "" Then
'https://msdn.microsoft.com/en-us/library/office/gg278418(v=office.15).aspx
b() = Filter(a(), "\" & fn & ".txt", True, vbTextCompare)
If UBound(b) <> -1 Then fnTXT = b(0)
End If

Select Case True
Case fn = "" Or fnTXT = ""
hCell.Value = ""
Case fnTXT <> ""
With hCell
'https://msdn.microsoft.com/en-us/library/aa265341(v=vs.60).aspx
'http://www.exceltrick.com/formulas_macros/filesystemobject-in-vba/
.Value = fso.GetFile(fnTXT).OpenAsTextStream(1, -2).ReadAll
'.Value = Replace(fso.GetFile(fnTXT).OpenAsTextStream(1, -2).ReadAll, vbCrLf, vbLf)
.WrapText = True
Columns(.Column).EntireColumn.AutoFit
Rows(.Row).EntireRow.AutoFit
End With
Range(c, hCell).VerticalAlignment = xlCenter
Case Else
End Select
Next c

EndSub:
On Error Resume Next
With Application
.Calculation = glb_origCalculationMode
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.CalculateBeforeSave = True
.Cursor = xlDefault
.StatusBar = False
.EnableCancelKey = xlInterrupt
End With
Set fso = Nothing
End Sub

dj44
11-19-2016, 10:40 AM
Hello Kenneth,

Thank you for givng up part of your Saturday to do this coding.

I was a bit scared to run it - it looks so complex, and i often break code when i fiddle with it.

But this is some advanced ninja coding - really really chuffed to bits for this help.:biggrin:

This is an extreme kind gesture, creating this great code for others benefit.

I appreciate the complexity of it as I really looked hard to find anything remotely similar on the web sphere that I could emulate and may be some how fix and add into the existing code.

It's hard to explain these situations to google - so it was all going no where.

I really struggle with programming, not because I don’t try but because most of the time I can't find what I need, and even then I write it alltogether wrong :doh:, i suppose i have 2 left hands when it comes to code.

Things like this are best left to the pro's.

This is such a useful program - because now I can put the file name in and sometimes when I misplace it I know the program will pick it up and save me a lot of stress.

The other day it took me half an hour to find a text file becuase it got misplaced somehwere and I could not for the life of me find it, and that had my important information log in - in it - that i was logging on to the spreadsheet.

I will sure study this CMD thing, I made a notebook for it and know where the window is.

Thank you for generously helping the newbies who I must say in my opinion do ask for a lot as i have
But without it we would be lost in the desert chasing mirages,I know i am feeling a bit poetic as i can chill now that this got solved-



And it's a privilege to have your time you deserve a trophy for this:trophy:


I hope you have a great weekend - thank you for making mine

Cheers my friend :friends: and enjoy your weekend
and folks too
:beerchug: