How to extract email addresses from 1 worksheet to another workbook
On Tue, 22 Nov 2011 08:16:51 -0500, Ron Rosenfeld wrote:
Cleaned up a bit with some error checking:
=============================
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
============================
|