Import data from multiple excel files in one folder

[WingZero]

I have a set of sequentially numbered files (starting at 1000.xls) in a main
folder that contains subfolders. I want to import data from certain fields,
with a new row for each file. I currently am using:

='P:\Folder 1\Main Folder\subfolder\[1002.xls]POForm1'!$L$1

to link to the data I want, modifying the file number by hand to update the
file. I have 32 different pieces of data that I am pulling from each file,
along with 6200 files and counting.....

 

[Ron de Bruin]

hi WingZero

Try this example
http://www.rondebruin.nl/summary2.htm

 

[WingZero]

Ron, thanks for the help, but I apparently need a bit more. =(

I just tried example one, and it will do what I need other than the small
detail of all the lines show as yellow, and none of the data that I need
comes in. Below is the modded script, including which cells I need.

Sub Summary_cells_from_Different_Workbooks_1()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "Sheet3" '<---- Change
Set Rng = Range("L1,D5,D7,D8,D9,F9,D10,J9,L9,L10,D40,B20,F19:F38")
'<---- Change

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files,
*.xl*", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 2
RwNum = 1

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'",
"''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName
& "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(,
, xlR1C1))
If Err.Number <> 0 Then
'If the sheet not exist in the workbook the row color will
be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = _
"=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub

 

[Ron de Bruin]

No problem here

Are you sure that every workbook have a sheet named "Sheet3" ?

 

[WingZero]

That was the issue. I don't know what I was thinking when I first read the
code, but I had "Sheet3" in my mind as being a sheet that was going to be
created when the code ran. This is what happens when you have to get up early
for work and you're not a morning person. =)

 

[Ron de Bruin]

Hi WingZero

Glad you got it working

This is above the code

Change these two lines before you run the macro with the sheet name and range in each
workbook that you select with GetOpenFilename
Note: If the sheet not exists in the workbook the row will be yellow.

ShName = "Sheet1" '<---- Change
Set Rng = Range("A1,D5:E5,Z10") '<---- Change

Looks OK for me but English is not my language so maybe it is not clear ?

 

[WingZero]

No, it is fairly clear, I just had my mind somwhere else I suppose.

A slightly better wording however, would be:

Change the following two lines of code before you run the macro. Each
workbook that is selected with GetOpenFilename should contain a sheet name
and data range that matches your changes.

Note: If the sheet does not exist in a selected workbook, that row will be
highlighted in yellow.

ShName = "Sheet 1" '<----------Change sheet name
Set Rng = Range("A1,D5:E5,Z10") '<----------Change selected cells


Thanks again for the help.

 

[Ron de Bruin]

Thanks

I will update the text