search & extract excel data to new sprdsht

Microsoft Office 2010 professional
September 9, 2010 at 09:47:37
Specs: Windows XP
We have 1000's of spreadsheets with various information about our customers. One piece of information is their email address, by itself in a cell (or more than one if, say a couple, has multiple email addresses). I want to be able to automatically search these files and extract the email addresses (or anything with @ in it) into a new spreadsheet (then sort, expunge as needed, etc.). Here is some code from another thread ( that is now closed. it seems that it will work, except I need to know how to get the cell data vs. the filename, which this code was designed to do.

Sub UseFileName()
Dim sfol As String
Dim SearchString As String
Dim MyFileName As String
Dim DataSht As String
'Define Source Folders - make this yours...
sfol = "C:\Documents and Settings\User\Desktop\Data Folder\"
'Set up Seach
With Application.FileSearch
.LookIn = sfol
.FileType = msoFileTypeAllFiles
If .Execute > 0 Then
'Loop Through Files
For i = 1 To .FoundFiles.Count
SearchString = "*Data*.*"
'Get Full Filename
MyFileName = Dir$(sfol & SearchString, vbNormal)
'Strip off extension (.xls) from Filename
DataSht = Left(MyFileName, Len(MyFileName) - 4)
'Put Formula in Column A
MyRow = MyRow + 1
Range("A" & MyRow).Formula = "='C:\Datapath\[" & DataSht & ".xls]Sheet1'!$A$28"
Next i
End If
End With
End Sub

See More: search & extract excel data to new sprdsht

September 10, 2010 at 05:30:21

The macro you have appears to open workbooks and create a series of formulas which consist of links to one cell (Sheet1, cell A28) in each workbook.

As far as I can see, your requirements are to open a series of workbooks, carry out a search an all worksheets in each workbook, find each occurrence of "@" and save the contents of the cell or cells containing "@".

From what you said, you don't need links to the source of the email addresses - just te e-mail addresses.

This macro allows you to select workbooks from any folder, it then opens each in turn and carries out a search on each worksheet in each selected workbook, copying the contents of cells that contain "@" to the first worksheet in the workbook that contains the macro.

I suggest that you create a new workbook and save it as a Macro-enabled workbook "yourname.xlsm"
Then add a button to Sheet1 as follows:
From the Ribbon select Developer (If it's not visible go to the File tab, select 'Options' at the bottom of the File menu list above 'Exit" and select the 'Customize Ribbon' tab in the 'Excel Options' Dialog box. In the 'Customize the Ribbon:' drop-down, select 'Main Tabs' and check the 'Developer' check box).

In Developer - Controls select Insert and choose the button icon (Button - Form control).
Draw the button on the worksheet
In the 'Assign Macro' dialog box select 'New'

In the code window that opens enter this:

Option Explicit

Sub Button1_Click()
Dim varFileName As Variant
Dim strFirstAddress As String
Dim rngLastCell As Range
Dim objFound As Object
Dim WBThis As Workbook
Dim wsEach As Worksheet
Dim strThisWB As String

'save name of this workbook
strThisWB = ActiveWorkbook.Name

'allow user to select workbooks of types xlx, xlsx, xlsm
'Open the file dialog
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = True
    .Filters.Add "Excel workbooks", "*.xls; *.xlsx; *.xlsm", 1
    'loop through each selected file
        For Each varFileName In .SelectedItems
            'open workbook
            Set WBThis = Workbooks.Open(Filename:=varFileName)
            'go through each worksheet in 'this' workbook
            For Each wsEach In WBThis.Worksheets()
                'reset first address
                strFirstAddress = ""
                Set objFound = wsEach.Cells.Find( _
                                What:="@", _
                                LookIn:=xlValues, _
                If Not objFound Is Nothing Then
                    'first find
                    'save first found address
                    strFirstAddress = objFound.Address
                    'save last cell found
                    Set rngLastCell = objFound
                    'save cell contents
                    Call SaveEM(objFound.Value, strThisWB)
                    'find again
                    Do While Not objFound Is Nothing
                        Set objFound = wsEach.Cells.Find( _
                                        What:="@", _
                                        After:=rngLastCell, _
                                        LookIn:=xlValues, _
                        'test if back at first found cell
                        'the find function loops back to the start!
                        If objFound.Address = strFirstAddress Then
                            'stop - by setting Found object to Nothing
                            Set objFound = Nothing
                        End If
                        'test if found
                        If Not objFound Is Nothing Then
                            'Found - so save cell contents
                            Call SaveEM(objFound.Value, strThisWB)
                            'keep this cell
                            Set rngLastCell = objFound
                        End If
                End If
            Next wsEach
            'close workbook
            WBThis.Close SaveChanges:=False
    Next varFileName
End With
End Sub

Note that Sub Button1_Click() and End Sub will already be present, so don't duplicate them. Option explicit goes before Sub Button1_Click().

Now add this subroutine after the End Sub of the main macro:

Private Sub SaveEM(CellValue As Variant, WBToSaveIn As String)
Dim rngNext As Range

With Workbooks(WBToSaveIn).Worksheets(1)
    'find first empty row in the first worksheet
    Set rngNext = .Range("A" & CStr(Application.Rows.Count)) _
                .End(xlUp).Offset(1, 0)
    'save the cell value
    rngNext.Value = CellValue
End With
End Sub

Click Save from the Visual Basic Menu.

Alt+f11 takes you back to the main Excel window.

Right click the button and Edit the name to something meaningful

As changes made by Macros cannot be undone with the Undo button, test this macro on a copy of your data. Always make a backup of your Workbook before running this macro. This code has only been tested on sample data, and it has not been tested in your environment, so test it on copies of your data to ensure that it works 'as expected'

After selecting any cell, the new command button should now respond to a click and run the macro.


Report •
Related Solutions

Ask Question