Merge Multi Workbook Results into One Spreadsheet

[dspa0712]

I have several Excel files (20 at present) all with different filenames saved in a location:

U:\MyWork

Within each workbook is one similar worksheet called "Pro", however there are different amounts of Worksheets called "Ser" on each Workbook.

On each of the Ser sheets are two cell ranges containing values (A1) Name and (B1) Value
eg

1st File
Location: U:\My Work
FileName: 123.xls
Worksheet Names: Pro _Ser1_Ser2_Ser3
Ser1 (A1) value= dfd
Ser1 (B1) value=10
Ser2 (A1) value= dd
Ser2 (B1) value=9
Ser1 (A1) value= de
Ser1 (B1) value=11


2nd File
Location: U:\My Work
FileName: 333.xls
Worksheet Names: Pro _Ser1
Ser1 (A1) value= db
Ser1 (B1) value=1


What I want is a master spreadsheet to 'suck up' data from all the Ser sheets within all Workbooks and populate the master spreadsheet with Column A =A1 Values from all the Workbook, Worksheets
Column B=B1 Values from all the Workbook, Worksheets

Output on Master Workbook will look like

Column A_____________________Column B

dfd___________________________10
dd____________________________9
de____________________________11
db____________________________1


Help please

 

[dspa0712]

Hope this explained what is needed and very curious as to whether you or anyone else with greater Excel experience than me can acheive this

 

[jindon]

dapa0712

Is it in a Local PC or newwork?

 

[ravishankar]

HI
Replace C:\ with your file path (U\mytest\) and sheet1/2/3 with ser1/2/3 and run the macro.

Sub pull()
Cells(2, 1).Select
F = Dir("C:\" & "*.xls")
Do While Len(F) > 0
ActiveCell.Formula = F
ActiveCell.Offset(3, 0).Select 'By row
F = Dir()
n = n + 1
Loop
x = Cells(Rows.Count, 1).End(xlUp).Row
For a = 2 To x Step 3
b = Cells(a, 1)
Cells(a, 3) = "='C:\[" & b & "]sheet1'!A1"
Cells(a, 4) = "='C: \[" & b & "]sheet1'!B1"
Cells(a + 1, 3) = "='C:\[" & b & "]sheet2'!A1"
Cells(a + 1, 4) = "='C: \[" & b & "]sheet2'!B1"
Cells(a + 2, 3) = "='C:\[" & b & "]sheet3'!A1"
Cells(a + 2, 4) = "='C: \[" & b & "]sheet3'!B1"
Next a
End Sub

It will list files in col A with 2 rows blank in between and col C & D with values of ser1/2/3
Ravi

 

[jindon]

try

Sub test()
Dim myDir As String, fn As String, ws As Worksheet, LastR As Range
myDir = "U\My Work"
On Erro GoTo Exit_Sub
CreateObject("Wscript.Shell").CurrentDirectry = myDir
fn = Dir("*.xls")
If fn = "" Then
     MsgBox "No .xls file in " & myDir
     Exit Sub
End If
Do While fn <> ""
     With Workbooks.Open(fn)
          For Each ws In .Worksheets
               If ws.Name Like "Ser*" Then
                    Set LastR = ThisWorkbook.Sheets(1).Range("a" & Rows.Count).End(xlUp).Offset(1)
                    LastR.Resize(,2).Value = Array(ws.Range("a1").Value, ws.Range("b1").Value)
              End If
          Next
          .Close False
     End With
     fn = Dir()
Loop
Exit Sub
Exit_Sub:
     MsgBox "Wrong path"
End Sub