macro to copy specific data from many workbook to one workbook

**anvesh.pune** · 07-01-2009, 02:24 AM

Dear All,

I have a excelFile(File Attached)
File contain following sheets
1 Form
2.File name
3.Purchase
4.Delayed Report

File name sheet contain location or Path where File is store
I need a macro to Do Following Action

On running code Open first (Purchase1.xls)
Find Delayed in Column F
If F1=Delayed than copy that Row
Paste entire row in Sheet Mention Delayed Report in Cell A2
Search Next Cell in F Column
if F2 not Equal to Delayed than leave
Search Next Cell in F Column
if F3 Equal to Delayed than Copy Entire Row
Paste entire row in Sheet Mention Delayed Report in Cell A3
Search Next Cell in F Column up to blank cell
If Cell number if F65536 than close Purchase1
Open Second File and Repate the proceess till end

Anyone help onthis
Thanks in Advance

ANVESH

**JBeaucaire** · 07-01-2009, 03:49 AM

Adjust your C2 formula so that the path includes the closing "\" and then put all your Purchase??.xls files into that folder.

Run this macro, it won't need FileName sheet, it will open every file in that folder with the correct name and pull in the data.

Code:

Option Explicit

Sub CollateReportFromFiles()
'JBeaucaire  (6/30/2009)
'Open all .XLS in specific folder and import data (2007 compatible)
Dim strFileName As String, strPath As String
Dim wbkOld As Workbook, wbkNew As Workbook, ws As Worksheet
Dim NR As Long, LR As Long

Application.EnableEvents = False
Application.DisplayAlerts = False

'Setup and clear old report
    Set wbkNew = ThisWorkbook
    strPath = Sheets("FORM").Range("C2")    'Your path, don't forget the final \
    strFileName = Dir(strPath & "Purchase*.xls")
    Set ws = Sheets("Delayed Report")
    ws.Activate
    ws.Cells.Clear

'Collect data in new report
    NR = 1
    Do While Len(strFileName) > 0
        Set wbkOld = Workbooks.Open(strPath & strFileName)
        Range("A1:F1").AutoFilter
        Range("A1:F1").AutoFilter Field:=6, Criteria1:="Delayed"
        LR = Range("A" & Rows.Count).End(xlUp).Row
        If LR > 1 Then
            Range("A2:F" & LR).Copy
            wbkNew.Activate
            ws.Range("A" & NR).PasteSpecial xlPasteAll
        End If
        NR = ws.Range("A" & Rows.Count).End(xlUp).Row + 1
        strFileName = Dir
        wbkOld.Close False
    Loop

ws.Columns("A:F").AutoFit
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub

**anvesh.pune** · 07-02-2009, 10:05 AM

Thanks J,

Your code is nice and it run, but the files are Protected.
On running code it give an Run Time Error 1004.

Kindly Help

**JBeaucaire** · 07-02-2009, 10:15 AM

Please provide all the information regarding how they are protected. Sheets/Books/Password or not?

**anvesh.pune** · 07-02-2009, 10:32 AM

Hi J

It is protected in following way
Tools\Protection\Protect Sheet
It is password protected for editing

**JBeaucaire** · 07-02-2009, 10:58 AM

Add the highlighted line of code where shown:

Code:

    Do While Len(strFileName) > 0
        Set wbkOld = Workbooks.Open(strPath & strFileName)
        ActiveSheet.Protect Password:="1234", UserInterfaceOnly:=True
        Range("A1:F1").AutoFilter
        Range("A1:F1").AutoFilter Field:=6, Criteria1:="Delayed"