Macro to find specific text in specific file name

[Sunvisor]

I have a specific directory and was able to get all the names of the files with the below code. They are now listed in column A, 1-400.

I used this code.

Sub listfiles()
Dim f As String, i As Integer
f = Dir("C:\Documents and Settings\M08040.ADNE\My Documents\Can Delete\Doug52WeekEmployee Volumes\")
i = 1
Do While Len(f) <> 0
    Cells(i, "A") = f
    f = Dir
    i = i + 1
Loop
End Sub
 
I now want to go into the directory and after Doug52WeekEmployee Volumes\ put the file name which is in A1-400...so something like Doug52WeekEmployee Volumes\A1.
 
Any ideas?..Also I then have the problem where I need it to find the specific text "Job Description:" and copy the 2 cells directly next to this word.
 
Thanks for any help guys!

 

[Sunvisor]

It's not working, the last two are showing blank when they actually have data to pull..we need to make sure it skips a line when its imputting the data...because we have a column of file names in order...so right now its showing the last two ...

 

[Sunvisor]

could it be somethign like row + 2 ? I just tried that though, don't think it worked...

 

[rconverse]

What list? How do you know the way the loop iterates through the directory is the same order as your list? Why not just add the file name as you paste the data you're extracting?

 

[Sunvisor]

Yea, that's what we need to do, How would we add the file name as we paste the data and also make sure we know which files do not have the data we are looking to extract.

we were pulling file names with a seperate macro

Sub listfiles()
Dim f As String, i As Integer
f = Dir("C:\Documents and Settings\My Documents\Can Delete")
i = 2
Do While Len(f) <> 0
Cells(i, "A") = f
f = Dir
i = i + 1
Loop
End Sub
[Code\]

 

[rconverse]

I'm on my phone now, so can't copy and paste.

There are two parts of the code where you're updating your file. Instead of pasting the found values in the last unused cell in column b as opposed to a.

Then just add this code to both places.

Range("a" & lngLastRow1).value = filepath

that will add the filename to column 1 and move the two cells you're copying to columns B & C.

I'll be home in an hour or so and can get back on my computer then.

 

[Sunvisor]

also I'm not sure what if
err.number > 0 Then

means..? If its looking for a word why would it be looking for a number?

hmm, just really trying to figure this out >.<

 

[rconverse]

If you're just going to delete the files where there is no "Jobs Total", you don't need to track both types of files. One is sufficient.

 

[rconverse]

also I'm not sure what if
err.number > 0 Then

means..? If its looking for a word why would it be looking for a number?

hmm, just really trying to figure this out >.<

When it doesn't find a match, it errors out. That's why above that I tell it what to do if it finds an error. So, when it finds an error it jumps to where it's supposed to go. However, if there is no error, you want to skip that step. Therefore if the error numbe is > 0, it will skip that step.

 

[Sunvisor]

I'm not exactly sure where to paste that file name code...
but in column A, we'd like to have the file name, B value 1, C value 2...If possible we'd like to have the file name and also if there is no "Total Jobs:", the file name and in Column B, 0 and Column C, 0 as well...

here is my code thus far...

Sub FindTotalJobs()
Dim path As String
Dim FileName As String
Dim Wkb As Workbook
Dim wsmf As Worksheet
Dim lngLastRow1 As Long
Dim wkb1 As Workbook
Dim rng As Range

Call ToggleEvents(False)
'###################################
path = "C:\Documents and Settings\M08040.ADNE\My Documents\Can Delete\Herndon52WeekEmployee Volumes" 'Change as needed
'###################################
FileName = Dir(path & "\*.xls", vbNormal) 'Change as needed (Are you looking for xls or xlsx files?)

Do Until FileName = ""

'this opens the workbook in the above specified folder
Set Wkb = Workbooks.Open(FileName:=path & "\" & FileName)

'set this to the sheet number to look at
Set wsmf = Wkb.Sheets(1) ' Use this line if want first sheet every time

'moves to next spreadsheet if no "Job Description" is not found
'on error goto NotFound

'finds job description
Set rng = wsmf.Cells.Find(What:="Total Jobs:", After:=Range("A1")).Offset(0, 1).Resize(, 2)
rng.Copy

'pastes the information in the last row of your spreadsheet
Windows("Ridiculous.xls").Activate
Set ws = ActiveWorkbook.Sheets(1)
lngLastRow1 = ws.Range("A65536").End(xlUp).Row + 1
Range("A" & lngLastRow1).Value = filepath
Range("A" & lngLastRow1).PasteSpecial xlPasteValues
Application.CutCopyMode = False

NotFound:

If Err.Number > 0 Then
Windows("Ridiculous.xls").Activate
Set ws = ActiveWorkbook.Sheets(1)
lngLastRow1 = ws.Range("A65536").End(xlUp).Row + 1
Range("A" & lngLastRow1).Value = filepath
Range("A" & lngLastRow1).Value = " "
End If

Err.Clear

FileName = Dir()

Wkb.Close

Loop
Call ToggleEvents(True)
End Sub

 

[rconverse]

I'm still on the train. I'll post updated code when I get home which will be about 30 minutes.