Loop trough workbooks and Paste values

[mduff]

Hi,
I was looking on the internet and the board and just could not seem to get what I was looking for. :banghead:

I need to loop through any workbooks that are open (or even better browse to a folder) and extract the same cell from each book and paste it into a summary workbook. The summary workbook is the one with the code but will not be included in the loop. the cell will always be j5 and I would like to have the File name and J5 from the WS Score pasted in the summary book.



So the end summary WB looking like this

a1 b2
Book name Value of j5 from sheet Score


Thanks in advance and let me know if you have any questions




ub WBLoop()
Dim wbk As Workbook, rngToCopy As Range, rngToPaste As Range

With Worksheets("Score")
For Each wbk In Workbooks
' loop through the Open workbooks
If wbk.Name <> ThisWorkbook.Name Then
' exclude this workbook from the Loop
Set rngToPaste = .Range("A65536").End(xlUp).Offset(1, 0)
'set the target For the paste
Set rngToCopy = wbk.Range("J5")
'set the range To be copied
rngToCopy.Copy Destination:=rngToPaste
'do the copying
End If


Thanks in advance and let me know if you have any questions

[GTO]

Can we count on each wb in the folder having a sheet named 'Source'?

[mduff]

yes We can

[mduff]

yes We can

[GTO]

Try:


Option Explicit

Sub exa()
Dim _
DIC As Object, _
fsoFol As Object, _
fsoFil As Object, _
aryLinks As Variant, _
strPath As String

strPath = ThisWorkbook.Path & "\"

'// Set a late bound reference to dictionary //
Set DIC = CreateObject("Scripting.Dictionary")

'// Basically, combine setting a reference to the FileSystemObject and the Folder we want//
Set fsoFol = CreateObject("Scripting.FileSystemObject").GetFolder(strPath)

'// This utterly presumes that nothing besides wb's exist in the folder, and that we only //
'// have to avoid ThisWorkbook. //
For Each fsoFil In fsoFol.Files
If Not fsoFil.Path = ThisWorkbook.FullName Then
'// Add an entry into the dictionary that we'll use as a formula //
DIC.Add fsoFil.Name, "='" & strPath & "[" & fsoFil.Name & "]Source'!$J$5"
End If
Next

'// Flip the .Items array so that it'll fit down a column easy. //
aryLinks = Application.Transpose(DIC.Items)

'// Use Ubound of the array to resize, plunk in the formulas, then overwrite with vals. //
With Range("A2").Resize(UBound(aryLinks, 1))
.Formula = aryLinks
.Value = .Value
End With
End Sub

[mduff]

Hi this code is way beyound me but every time I try to run it it is plluing in infromation from the my docs folder Do i need to save it in the same folder as the infromation is in?