OK thanks for that Ron, it looks like it will work properly but I have
2 small problems still.
1) Unfortunately the folder I am scraping from is not mine so it has
the occassional rubbish leftover file that starts with ~$ that office
leaves behind. The macro errors when trying to open that. This is
minor and I can get around it by copying and pasting to another
folder.
Why not just test the filenames as I indicated you could in the file open routine?
This part here:
========================
Set Fo = oFS.GetFolder(Path)
For Each F In Fo.Files
Debug.Print F.Name 'This line just for debugging
'If it returns the correct filenames, uncomment the
'next line, and delete the debug.print line
'you could also include some testing for file names if you
'don't need to open all the files in the folder
'Workbooks.Open (Path & F.Name)
Next F
===============================
Change the area between
For Each F and Next F to:
If Not F.Name Like "~$*" then
Workbooks.Open(Path & F.Name)
end if
2) I am getting a subscript out of range error (run time error 9) with
the following line highlighted
Set rSrc = wb.Worksheets("Admin").UsedRange
I believe it might be because the the code says
For Each wb In Workbooks
yet wb is not defined anywhere. Would that be correct? I've tried a
few different things but they all fail and bring up a new error
You are probably using the first version of the ExtrEmails macro where I did not check to be sure an Admin worksheet was present, because that would give that error. But wb was declared in the declarations area on both versions, so I don't know why you don't have that line there.
Here is that second version again:
=============================
Option Explicit
Sub ExtrEmails()
Dim rSrc As Range, c As Range
Dim rDest As Range
Dim wb As Workbook, ws As Worksheet
Dim vRes() As Variant
Dim i As Long
Dim re As Object, mc As Object
Dim bFirstRun As Boolean
Const sPatEmail As String = "\b[A-Z0-9._%+-]+@(?:[A-Z0-9-]+\.)+[A-Z]{2,6}\b"
'Set up location where you want results to go
Set rDest = ThisWorkbook.Worksheets("Sheet1").Range("A1")
rDest.Worksheet.Cells.ClearContents
Set re = CreateObject("vbscript.regexp")
With re
.Pattern = sPatEmail
.Global = True
.ignorecase = True
End With
bFirstRun = True
For Each wb In Workbooks
If Not wb.Name = "Book3" Then 'or whatever book holds the results
On Error Resume Next
Set ws = wb.Worksheets("Admin")
On Error GoTo 0
If Not ws Is Nothing Then
Set rSrc = wb.Worksheets("Admin").UsedRange
For Each c In rSrc
If re.test(c.Text) = True Then
Set mc = re.Execute(c.Text)
If bFirstRun = False Then
ReDim Preserve vRes(0 To UBound(vRes) + mc.Count)
Else
ReDim vRes(0 To mc.Count - 1)
bFirstRun = False
End If
For i = 1 To mc.Count
vRes(UBound(vRes) - mc.Count + i) = mc(i - 1)
Next i
End If
Next c
End If
End If
Next wb
If bFirstRun = False Then
Set rDest = rDest.Resize(rowsize:=UBound(vRes) + 1)
rDest = WorksheetFunction.Transpose(vRes)
End If
End Sub
============================
And I have also noted a problem with the File Handling routines that I will correct here; it has to do with the File Close routine:
====================================
'requires reference to Microsoft Scripting Runtime
Public wbk As Workbook
Public Path As String
Public wbPrefix As String
Public wbName As String
Public oFS As FileSystemObject, Fo As Folder, F As File
Option Explicit
Option Private Module
Public Sub OpenEmailSourceFiles()
'note the terminal "\" in Path definition
Path = "Your_Path" & "\"
Set oFS = New FileSystemObject
Set Fo = oFS.GetFolder(Path)
For Each F In Fo.Files
Debug.Print F.Name 'This line just for debugging
'If it returns the correct filenames, uncomment the
'next line, and delete the debug.print line
'you could also include some testing for file names if you
'don't need to open all the files in the folder
'Workbooks.Open (Path & F.Name)
Next F
Set oFS = Nothing
End Sub
'-------------------------------------------------------
Public Sub CloseEmailSourceFiles()
'clean up the mess by closing all those files
For Each wbk In Workbooks
If wbk.Name <> "The Name Of Your Results File" Then
wbk.Close savechanges:=False
End If
Next wbk
End Sub
========================
