Excell Macro

[djeerd]

I have a folder named "FAB" on my desktop. Inside the folder "FAB" I have 850 Excell spreadsheet files. I need to get some data off each file and have it put it on a new spreadsheet. The data is in cell A2, B2, D5 and E10 for each of the 850 files. I am running Windows 7

 

[ziad alsayed]

which version of excel are using.

open the FAB folder,click inside the title copy the path and send it to me.

 

[Ruddles]

Assuming the data is in Sheets(1) of each of those files, maybe something along these lines:-

[FONT=Fixedsys]Option Explicit[/FONT]
 
[FONT=Fixedsys]Public Sub GetDataFromFolder()[/FONT]
 
[FONT=Fixedsys]  Const sFolder As String = "[COLOR=red]C:\Desktop\FAB\[/COLOR]"[/FONT]
 
[FONT=Fixedsys]  Dim sFilename As String[/FONT]
[FONT=Fixedsys]  Dim ws As Worksheet[/FONT]
[FONT=Fixedsys]  Dim wkbk As Workbook[/FONT]
[FONT=Fixedsys]  Dim iRow As Long[/FONT]
[FONT=Fixedsys]  Dim dStart As Date[/FONT]
 
[FONT=Fixedsys]  dStart = Now()[/FONT]
[FONT=Fixedsys]  Set ws = ThisWorkbook.Sheets(1)[/FONT]
[FONT=Fixedsys]  ws.UsedRange.ClearContents[/FONT]
[FONT=Fixedsys]  ws.Range("A1:D1") = Array("A2", "B2", "D5", "E10")[/FONT]
[FONT=Fixedsys]  iRow = 1[/FONT]
[FONT=Fixedsys] [/FONT]
[FONT=Fixedsys]  sFilename = Dir(sFolder & "*.xl*")[/FONT]
[FONT=Fixedsys]  Do Until sFilename = ""[/FONT]
[FONT=Fixedsys]    Application.EnableEvents = False[/FONT]
[FONT=Fixedsys]    Set wkbk = Workbooks.Open(sFolder & sFilename, , True)[/FONT]
[FONT=Fixedsys]    Application.EnableEvents = True[/FONT]
[FONT=Fixedsys]    iRow = iRow + 1[/FONT]
[FONT=Fixedsys]    With wkbk.[COLOR=blue]Sheets(1)[/COLOR][/FONT]
[FONT=Fixedsys]      .Range("A2").Copy Destination:=ws.Cells(iRow, "A")[/FONT]
[FONT=Fixedsys]      .Range("B2").Copy Destination:=ws.Cells(iRow, "B")[/FONT]
[FONT=Fixedsys]      .Range("D5").Copy Destination:=ws.Cells(iRow, "C")[/FONT]
[FONT=Fixedsys]      .Range("E10").Copy Destination:=ws.Cells(iRow, "D")[/FONT]
[FONT=Fixedsys]    End With[/FONT]
[FONT=Fixedsys]    Application.EnableEvents = False[/FONT]
[FONT=Fixedsys]    wkbk.Close (False)[/FONT]
[FONT=Fixedsys]    Application.EnableEvents = True[/FONT]
[FONT=Fixedsys]    sFilename = Dir()[/FONT]
[FONT=Fixedsys]  Loop[/FONT]
[FONT=Fixedsys] [/FONT][FONT=Fixedsys] [/FONT]
[FONT=Fixedsys]  MsgBox "Done: " & CStr(iRow - 1) & " files imported" _[/FONT]
[FONT=Fixedsys]       & Space(10) & vbCrLf & vbCrLf _[/FONT]
[FONT=Fixedsys]       & "Run time: " & Format(Now() - dStart, _[/FONT]
[FONT=Fixedsys]       "hh:nn:ss"), vbOKOnly + vbInformation[/FONT]
 
[FONT=Fixedsys]End Sub[/FONT]

 

[Ruddles]

You could add these lines immediately before iRow = 1:-

  ws.Range("A1:D1").Font.Bold = True
  ws.Range("A1:D1").Interior.Color = RGB(224, 224, 224)

 

[djeerd]

I cannot get this code to work.

Fab is located at "C:\Users\david\Desktop\Fab"

And the excell sheet where the data is located is labled "cover". Some of the files are xls and some are xlsx

I am using Excell 2007

 

[Ruddles]

What does it do and what does it not do? Does it stop with an error? Does anything happen at all?

Did you change the bits in red and blue to suit your requirements?

 

[djeerd]

The Macro Runs and I get a message "Done "0" files imported. Run Time 00:00:00"

The spreadsheet shows:

A2 in Cell A1
B2 in Cell B1
D5 in Cell C1
E10 in Cell D1

 

[Ruddles]

Did you change the bits in red and blue to suit your requirements?

Did you do this?

 

[djeerd]

I created a new folder with three excel files in it and your macro worked.

When I changed some items to fit my data and folder it did not. I got the message "Oblect dosen't support this property or method".

Below is the code with the folder C:/Users/David/Desktop/Fab1. The excel files with the data has "cover" as the page name. I also added the correct cells where the data is, O3, D6, N40 and N39.

Option Explicit

Public Sub GetDataFromFolder()

Const sFolder As String = "C:\Users\David\Desktop\FAB1\"

Dim sFilename As String
Dim ws As Worksheet
Dim wkbk As Workbook
Dim iRow As Long
Dim dStart As Date

dStart = Now()
Set ws = ThisWorkbook.Sheets(1)
ws.UsedRange.ClearContents
ws.Range("A1:D1") = Array("O3", "D6", "N40", "N39")
iRow = 1

sFilename = Dir(sFolder & "*.xl*")
Do Until sFilename = ""
Application.EnableEvents = False
Set wkbk = Workbooks.Open(sFolder & sFilename, , True)
Application.EnableEvents = True
iRow = iRow + 1
With wkbk.Cover
.Range("O3").Copy Destination:=ws.Cells(iRow, "A")
.Range("D6").Copy Destination:=ws.Cells(iRow, "B")
.Range("N40").Copy Destination:=ws.Cells(iRow, "C")
.Range("N39").Copy Destination:=ws.Cells(iRow, "D")
End With
Application.EnableEvents = False
wkbk.Close (False)
Application.EnableEvents = True
sFilename = Dir()
Loop

MsgBox "Done: " & CStr(iRow - 1) & " files imported" _
& Space(10) & vbCrLf & vbCrLf _
& "Run time: " & Format(Now() - dStart, _
"hh:nn:ss"), vbOKOnly + vbInformation

End Sub


When I get the error message one of the excell files i am trying to get data from stays open and i need to close it. When i close the file the spreadsheet with the macro in it has o3 in cell a1, D6 in cell b1, n40 in cell c1 and n39 in cell d1 (no data)

 

[Ruddles]

Change With wkbk.Cover to With wkbk.Sheets("Cover")