Hi,

I'm trying to get all the email addresses from a worksheet called
"Admin" across to a separate workbook.

I am able to copy and paste from a specific cell but certain workbooks
have the email address in different cells so I need something that
gets all the email addresses in a particular sheet and spits it out to
the new workbook.

I keep getting no addresses at all while attempting to do this
currently.

Thanks,
Mark.

Details Mark, we need details...

How many email addresses on a single sheet... one, many?

Will the email address(es) be found in a single column or, if more than one,
are they scattered all about on the sheet?

If in a single column, is that column the same for each worksheet?


Rick Rothstein (MVP - Excel)

On Nov 22, 3:00*am, "Rick Rothstein"
wrote:
Details Mark, we need details...

How many email addresses on a single sheet... one, many?

Will the email address(es) be found in a single column or, if more than one,
are they scattered all about on the sheet?

If in a single column, is that column the same for each worksheet?

Rick Rothstein (MVP - Excel)

As Rick says, details, but you may eventually use a macro using
FINDNEXT to look for partial hits on "@" and moving that cell or row
or? from _____ to where_____________

On Nov 22, 8:00*pm, "Rick Rothstein"
wrote:
Details Mark, we need details...

How many email addresses on a single sheet... one, many?

Will the email address(es) be found in a single column or, if more than one,
are they scattered all about on the sheet?

If in a single column, is that column the same for each worksheet?

Rick Rothstein (MVP - Excel)

Yeah sorry guys found it hard to be specific without including loads
of useless rubbish too :)

But to answer questions.

Sometimes the Admin sheet will have 1 email address but other times it
will have many.
These will generally be in columns D-F (unfortunately i don't have
control of those sheets otherwise they'd all be in the exact same
cell)

Will try out Ron's script and let you guys know how i go.

Thanks for the advice.

Oh 1 more thing I forgot is that it will be opening multiple workbooks
in a specific folder e.g ("mark\documents\data")

On Tue, 22 Nov 2011 16:17:48 -0800 (PST), Mark wrote:

Oh 1 more thing I forgot is that it will be opening multiple workbooks
in a specific folder e.g ("mark\documents\data")

If you try my script, try it first after you manually open all of the documents -- we can include that once we get the basics ironed out.

Tried Ron's and it works to a degree. If I have the specified file
open already it will extract all emails perfectly.

However as I mentioned above it will need to open multiple workbooks
from a folder. I currently have the following extra code in addition
to Rons but it is not opening any workbooks.


Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim FNum As Long

MyPath = "\\mypath"

FNum = 0
Do While FilesInPath < ""
FNum = FNum + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop


If FNum 0 Then
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set wb = Nothing
On Error Resume Next
Set wb = Workbooks.Open(MyPath & MyFiles(FNum))
On Error GoTo 0


However no workbooks try to open.

This is a work project btw and I'll be off from now for the next 48
hours so most likely wont look here again until then.

Thanks again for the help.

On Nov 23, 12:10*pm, Ron Rosenfeld wrote:
On Tue, 22 Nov 2011 16:17:48 -0800 (PST), Mark wrote:
Oh 1 more thing I forgot is that it will be opening multiple workbooks
in a specific folder e.g ("mark\documents\data")

If you try my script, try it first after you manually open all of the documents -- we can include that once we get the basics ironed out.


OK that worked perfectly with it open (I wrote this earlier but it
hasn't appeared so sorry if this doubles up later)

In addition to your code I have

Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim FNum as Long

MyPath = "mypath"

FNum = 0
Do While FilesInPath < ""
FNum = FNum + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop

If FNum 0 Then
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set wb = Nothing
On Error Resume Next
Set wb = Workbooks.Open(MyPath & MyFiles(FNum))
On Error GoTo 0
=====================================

however it is not opening any books.

Thanks again for all your help with this.

Ps. this is a work project and I won't be back here for another 48
hours so there may be a delay in my next response.
'

Tried Ron's and it works to a degree. If I have the specified file
open already it will extract all emails perfectly.

However as I mentioned above it will need to open multiple workbooks
from a folder. I currently have the following extra code in addition
to Rons but it is not opening any workbooks.

Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
FNum As Long


MyPath = "\\NBN2k8003\Data\NSOC - Docklands\Access Seekers\Access
Seeker Contact Matrices.Fibre"

On Mon, 21 Nov 2011 23:13:56 -0800 (PST), Mark wrote:

Hi,

I'm trying to get all the email addresses from a worksheet called
"Admin" across to a separate workbook.

I am able to copy and paste from a specific cell but certain workbooks
have the email address in different cells so I need something that
gets all the email addresses in a particular sheet and spits it out to
the new workbook.

I keep getting no addresses at all while attempting to do this
currently.

Thanks,
Mark.

You don't give a lot of information about your setup, with which the following might be able to be simplified.

The macro below will iterate through all open workbooks that have a worksheet named Admin, omitting the workbook where you want to put the results (Book3 in this version, but you can change it). It will look through the entire worksheet for anything that looks like an email address (excluding email addresses that are designated by an IP address) and place them into an array). The email addresses can be alone in a cell; embedded within text; and there can be more than one email address in a cell.

It will then output those email addresses into column A on Sheet1 of Book3 (or whatever you designate).

To enter this Macro (Sub), <alt-F11 opens the Visual Basic Editor.
Ensure your project is highlighted in the Project Explorer window.
Then, from the top menu, select Insert/Module and
paste the code below into the window that opens.

The macro can be in any workbook, but it would be best to place it in the workbook that stores your email addresses.

To use this Macro (Sub), <alt-F8 opens the macro dialog box. Select the macro by name, and <RUN.

========================================
Option Explicit
Sub ExtrEmails()
Dim rSrc As Range, c As Range
Dim rDest As Range
Dim wb As Workbook
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 = Workbooks("Book3").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
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
Next wb

Set rDest = rDest.Resize(rowsize:=UBound(vRes) + 1)
rDest = WorksheetFunction.Transpose(vRes)

End Sub
================================

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
============================