editing macro to pull multiple cells instead of a single cell

[spence]

Thanks to a very helpful gentleman on these boards, I have
used the below pasted code, I have created a macro that
pulls the values from cell B4 in all the sheets in a
folder and puts them in column A on a new sheet. I'm
wondering if someone can help me edit the code so that I
can pull from four non-adjacent cells and then dump into
columns A-D in my new sheet. The cells in question are B4,
B6, B7, and G4.

Thanks,
spence


Sub TestFile1()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim rnum As Long
Dim SourceRcount As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String

SaveDriveDir = CurDir
MyPath = "C:\Documents and
Settings\rspence\Desktop\Updated Reports"
ChDrive MyPath
ChDir MyPath
FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "no files in the Directory"
ChDrive SaveDriveDir
Exit Sub
End If

Application.ScreenUpdating = False
Set basebook = ThisWorkbook
basebook.Worksheets(1).Cells.Clear
rnum = 1

Do While FNames <> ""
Set mybook = Workbooks.Open(FNames)
Set sourceRange = mybook.Worksheets(1).Range("B4")
SourceRcount = sourceRange.Rows.Count
Set destrange = basebook.Worksheets(1).Cells(rnum, "A")

With sourceRange
Set destrange = basebook.Worksheets(1).Cells(rnum, "A"). _
Resize(.Rows.Count, .Columns.Count)

End With
destrange.Value = sourceRange.Value

mybook.Close False
rnum = rnum + SourceRcount
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub

 

[Debra Dalgleish]

The following revised code will pull the data from the four cells:

'=====================
Sub TestFile2()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim rnum As Long
Dim SourceRcount As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String
Dim c As Range 'added new variable
Dim i As Integer 'added new variable

SaveDriveDir = CurDir
MyPath = _
"C:\Documents and Settings\rspence\Desktop\Updated Reports"
ChDrive MyPath
ChDir MyPath
FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "no files in the Directory"
ChDrive SaveDriveDir
Exit Sub
End If

Application.ScreenUpdating = False
Set basebook = ThisWorkbook
basebook.Worksheets(1).Cells.Clear
rnum = 1

Do While FNames <> ""
Set mybook = Workbooks.Open(FNames)
'changed from here ***********************
Set sourceRange = mybook.Worksheets(1).Range("B4,B6,B7,G4")
SourceRcount = sourceRange.Rows.Count
Set destrange = basebook.Worksheets(1).Cells(rnum, "A")

i = 0
For Each c In sourceRange
destrange.Offset(0, i).Value = c.Value
i = i + 1
Next c
'to here **************************************
mybook.Close False
rnum = rnum + SourceRcount
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub
'========================