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!

 

[rconverse]

Here you go.

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 "Total Jobs:" is not found
        On Error GoTo NotFound
        
        'searches for "Total Jobs:" and copies the two cells to the right.
        Set rng = wsmf.Cells.Find(What:="Total Jobs:", After:=Range("A1")).Offset(0, 1).Resize(, 1)
        rng.Copy
        
        'pastes the information in the last row of your spreadsheet
        Windows("Ridiculous.xls").Activate
        Set ws = ActiveWorkbook.Sheets(1)
        lngLastRow1 = ws.Range("B65536").End(xlUp).Row + 1
        Range("B" & lngLastRow1).PasteSpecial xlPasteValues
        Range("A" & lngLastRow1).Value = FilePath
        Application.CutCopyMode = False
    
NotFound:

    If Err.Number > 0 Then
        Windows("Ridiculous.xls").Activate
        Set ws = ActiveWorkbook.Sheets(1)
        lngLastRow1 = ws.Range("B65536").End(xlUp).Row + 1
        Range("A" & lngLastRow1).Value = FilePath
        Range("B" & lngLastRow1).Value = 0
        Range("C" & lngLastRow1).Value = 0
    End If
    
    Err.Clear
    
    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

 

[Sunvisor]

I really appreciate your help. When I run this, it does the same thing. It lists numbers in column B, now its missing the column to the right of that..it's also missing file path names. Not sure what to do at this point...It's just not skipping a line every time there is an error and that's what we really need it to do.

 

[Sunvisor]

Okay, so I may have found one of the problems..The first batch we are going through is 400 files. One of them has two blank cells to the right of "Total Jobs" so its not what I thought. Its the only file that contacts nothing to the right of "Total Jobs:"... its copying and pasting this information (nothing) into excel but excel is recognizing it as an empty cell when it goes to the next sheet so its not actually skipping...this seems to be a big problem ><

I am going to try and figure out how to tell it, if cells are empty copy paste value 0 0

 

[rconverse]

Okay, so I may have found one of the problems..The first batch we are going through is 400 files. One of them has two blank cells to the right of "Total Jobs" so its not what I thought. Its the only file that contacts nothing to the right of "Total Jobs:"... its copying and pasting this information (nothing) into excel but excel is recognizing it as an empty cell when it goes to the next sheet so its not actually skipping...this seems to be a big problem ><

I am going to try and figure out how to tell it, if cells are empty copy paste value 0 0

Well, that would do it for sure.

This should work. It places zeros in the cells if they're blank.

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 "Total Jobs:" is not found
        On Error GoTo NotFound
        
        'searches for "Total Jobs:" and copies the two cells to the right.
        Set rng = wsmf.Cells.Find(What:="Total Jobs:", After:=Range("A1")).Offset(0, 1).Resize(, 1)
        rng.Copy
        
        'pastes the information in the last row of your spreadsheet
        Windows("Ridiculous.xls").Activate
        Set ws = ActiveWorkbook.Sheets(1)
        lngLastRow1 = ws.Range("B65536").End(xlUp).Row + 1
        ws.Range("B" & lngLastRow1).PasteSpecial xlPasteValues
        ws.Range("A" & lngLastRow1).Value = FilePath
        Application.CutCopyMode = False

[B]            'check to make sure the pasted cells have values
            'if no value present, place zeros in the cells
            If Len(ws.Range("B" & lngLastRow1).Value) + Len(ws.Range("C" & lngLastRow1).Value) = 0 Then
                ws.Range("B" & lngLastRow1).Value = 0
                ws.Range("C" & lngLastRow1).Value = 0
            End If[/B]

    
NotFound:

    If Err.Number > 0 Then
        Windows("Ridiculous.xls").Activate
        Set ws = ActiveWorkbook.Sheets(1)
        lngLastRow1 = ws.Range("B65536").End(xlUp).Row + 1
        ws.Range("A" & lngLastRow1).Value = FilePath
        ws.Range("B" & lngLastRow1).Value = 0
        ws.Range("C" & lngLastRow1).Value = 0
    End If
    
    Err.Clear
    
    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