Importing single cells from multiple workbooks

[theboynorris]

Hi

I have a folder that contains 1600 excel files. The files are product spec sheets. I need to extract some of the information from these workbooks to one excel sheet in a new document.
The 1600 excel files are identical in layout. The information I want is not in adjoining rows or cells, I need to select 10 individual cells to import.
I deally what I would like is to be able to import all the data, and write it horizontally across the page, so each file you have one row on the new sheet, and corresponging values from the different spec sheets would appear below each other.
I am currently able to import a range of rows using this code
Option Explicit
Sub GetMyData()
Dim MyDir, FN As String
Dim LR As Long
Application.ScreenUpdating = False

'Runtime
MyDir = "C:\Documents and Settings\....\"

FN = Dir(MyDir & "*.xls")
Do While FN <> ""
If FN <> ThisWorkbook.Name Then
With Workbooks.Open(MyDir & FN)
LR = ThisWorkbook.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
.Sheets("Sheet1").Rows("3:22").Copy ThisWorkbook.Sheets("Sheet1").Rows(LR + 1)
.Close False
End With
End If
FN = Dir
Loop
Application.ScreenUpdating = True
End Sub
But this is no longer sufficient for my needs, and it would be great if I could just take the individual cells I require.
Thanks a million for any help you can give me.

 

[JackDanIce]

You haven't stated the location of the 10cells you want to import and place into the single row

 

[Dartagnan]

The following sub and functions might help.

'This Macro/VBA will copy data from multiple worksheets. Right now it creates a merge worksheet based on data found in b1.
Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

' Delete the summary sheet if it exists.
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Merge").Delete
On Error GoTo 0
Application.DisplayAlerts = True

' Add a new summary worksheet.
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Merge"

' Loop through all worksheets and copy the data to the
' summary worksheet.
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then

' Find the last row with data on the summary worksheet.
Last = LastRow(DestSh)

' Specify the range to copy. This will copy B1 from
' all worksheets found.
Set CopyRng = sh.Range("b1")

' Test to see whether there are enough rows in the summary
' worksheet to copy all the data.
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the summary worksheet to place the data."
GoTo ExitTheSub
End If

' This statement copies values and formats from each
' worksheet.
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

' Optional: This statement will copy the sheet
' name in the H column.
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name

End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

' AutoFit the column width in the summary sheet.
DestSh.Columns.AutoFit

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
'CopyRangeFromMultiWorksheets2
End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function

Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function

 

[theboynorris]

You haven't stated the location of the 10cells you want to import and place into the single row

A5
B7
C7
D5
E5
A14
B22
C18
D9
E24

I didn't know what to replace ".rows("3:22")" with to select multiple individual cells.


@Dartagnan: Thank you, I will take a closer look at your post.