Macro needed to extract a text in particular cell in a workbook

[vignesh_thegame]

Hi,
i have around 1000 workbook with same formats in a folder, i need a macro that opens all the workbook and copy ROW 5 text alone and paste this in another excel one by one...

i have given a example below of how my excel is.... i need to extract the "Upper Saddle River, NJ" text which was on column A,B,C in row 5 to another excel. This macro must open all my 1000 workbooks and extract the text and place in a single excel one by one.. Can any one help me on this.???

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

1

Attn:

2

Savoula Amanatidis

Invoice Date:

12-17-2013

3

Prentice Hall - ECP

LW ME Job #:

9482

4

1 Lake Street

P.O. #:

0411662826-1

5

Upper Saddle River, NJ

07458

Invoice #:

26103 F

6

Final invoice on your title, Troyka

7

Quick Access Compact

<tbody>
</tbody>

 

[ParamRay]

.
.

Please try the following macro. You don't need to have any of your workbooks already open in order to run the macro; simply run it from a new workbook.

Before running, you'll first need to change the line SFold = "C:\Users\jsmith\Desktop" to match the path where your workbooks are located.

Please also note that, if you're looping through 1,000+ workbooks, the macro will likely take some time to run. Therefore, I've placed an alert at the end that will tell you when it has finished running.

Sub Copy_A5_Value()

    'For source books:
    Dim SFold As String
    Dim SFile As String
    Dim SPath As String
    Dim SBook As Workbook
    Dim SNumb As Long
    
    'For destination book:
    Dim DBook As Workbook
    
    'Set folder containing source books
    'Change as necessary...
    SFold = "C:\Users\jsmith\Desktop"
    
    SFile = Dir(SFold & Application.PathSeparator & "*.xl*")
    
    'Exit if no source books found
    If SFile = vbNullString Then
        MsgBox _
            Prompt:="No files found.", _
            Buttons:=vbCritical
        Exit Sub
    End If
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    'Create destination book
    Set DBook = Workbooks.Add
    
    'Loop through source
    'books and copy
    'values from cell A5...
    
    SNumb = 0
    Do While SFile <> vbNullString
        SNumb = SNumb + 1
        SPath = SFold & Application.PathSeparator & SFile
        Set SBook = Workbooks.Open(Filename:=SPath)
        SBook.Worksheets(1).Range("A5").Copy
        DBook.Worksheets(1).Range("A" & SNumb).PasteSpecial Paste:=xlPasteValues
        SBook.Close SaveChanges:=False
        SFile = Dir
    Loop
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    
    'Notification that
    'macro is finished...
    
    MsgBox _
        Prompt:="Finished.", _
        Buttons:=vbInformation

End Sub