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!

 

[Kathleen0422]

Sheets("Files").Select
Range("A1").Select

Do While ActiveCell.Value <> ""

TheFileName = ActiveCell.Value

ActiveCell.Offset(0, 1).Select
NewFileName = ActiveCell.Value
RowSelected = Activecell.row - 1


FileCopy "C:\#####\" & TheFileName, "C:\#####\#####\" & NewFileName & " " &
RowSelected

ActiveCell.Offset(1, -1).Select

Loop

 

[Sunvisor]

I'm not exactly sure what I need to do to manipulate it, do I need to change "NewFileName" or anything also is it copying and pasting the offsetted values to a new sheet?

Thanks for the start!

 

[Sunvisor]

Also I need it to very specifically go to the first cell with "Job Description:" and copy the two cells directly to the left of this in each file

 

[Kathleen0422]

NewFileName is a variable which is being set as it loops through the list of file names.
RowSelected is the actual row you are on in the process.

I am assuming your list begins in Cell A2 with A1 being reserved for a title. This routine is not opening the files merely making a copy of them and saving them to the new location.

FileCopy "C:\Documents and Settings\M08040.ADNE\My Documents\Can Delete\Doug52WeekEmployee Volumes\" & NewFileName & "), :C:\Doug52WeekEmployee Volumes\") & NewFileName & "A" & RowSelected

Is Job Description in a set cell in every file. If so what is the cell address?

 

[Sunvisor]

it's not set I just need to find that cell somehow and then copy the two cells to the right of that word

 

[Sunvisor]

What im trying to say is I have a list A2-A400 of directory names
C:\MyDocuments....

I need a macro to go into each of these files in the folder and search for that specific word and then extract the two numbers to the right of that specific word for each and every file in that folder. I don't need to make a copy of the files or anything like that.

 

[rconverse]

What about something like this? You don't need a list of your filenames.

This will go through a folder and search all Excel files for "Job Description" and return the two cells to the left.

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\rconverse\My Documents\Test1"  '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:="Job Description:", After:=Range("A1")).Offset(0, -2).Resize(, 2)
        rng.Copy
        
        'pastes the information in the last row of your spreadsheet
        Windows("YourSpreadsheetName.xls").Activate
        Set ws = ActiveWorkbook.Sheets(1)
        lngLastRow1 = ws.Range("A65536").End(xlUp).Row + 1
        Range("A" & lngLastRow1).PasteSpecial xlPasteValues
        Application.CutCopyMode = False
    
NotFound:

    FileName = Dir()
    
    Wkb.Close
    
    Loop

Call ToggleEvents(True)

End Sub
Sub ToggleEvents(blnState As Boolean)

'Originally written by firefytr
    
    With Excel.Application
        .DisplayAlerts = blnState
        .EnableEvents = blnState
        .ScreenUpdating = blnState
        If blnState Then .CutCopyMode = False
        If blnState Then .StatusBar = False
    End With
    
End Sub

HTH,
Roger

 

[Kathleen0422]

Sorry, didn't understand your question to begin with. Think rconverse's suggestion will do what you want.

 

[Sunvisor]

Thanks Roger, I tried it with my info and it gave me a "Compile Error: Sub or Function not defined" It's highlighting Sub "CountTotalJobs()" in yellow and highlighting Call Toggle Events too.