Solved: Summary Extracted Data from multiple sheets from Different workbook

[tlchan]

I wish to summary data in Master.xls according to branches extracted from specific cells from all sheets in different workbook sources.xls. Data to be extracted are from same cell address for all sheets in source file. How could I used vba to accomplish this task as there are 35 sheets in the sources file.

I manage to use vba (per module1) to complete extraction from sheet A but there are 35 sheets. How am I to get around it.

Than you


sample workbook attached

[Simon Lloyd]

I've not looked at your example but if you have working code and it's simply a matter of getting it to work with the other sheets then use this to loop through them[VBA]Sub Loop_thru_Sheets()
Dim Sh As Worksheet
For each Sh in Sheets
'YOUR WORKING CODE HERE
Next Sh
End Sub[/VBA]You may have to change Sheets for Workbooks("sources.xls").Sheets
I haven't tested any of this just written it to give you an idea, when i get home later i'll take a look if i have a few minutes

[tlchan]

Thanks Simon. I hope you may help me out as I am still lost to get it work around.

[tlchan]

I try out Simon's tips but the result only show at row 20 instead of A2 in the formatted table under sheet("summary") using the following code. Can anyone help to rectify?

Thanks


[VBA]Option Explicit
Sub Extract()
Dim wbdata As Workbook
Dim wbmaster As Workbook
Dim ws As Worksheet
Dim sFileName As String
Dim lastrow As Long
Application.ScreenUpdating = False
On Error Resume Next
sFileName = Application.GetOpenFilename
If sFileName = "False" Then Exit Sub
Set wbdata = Workbooks.Open(sFileName)
lastrow=ThisWorkbook.Worksheets("summary").Range("A65536").End(xlUp).Offset (1, 0)
For Each ws In wbdata.Worksheets
ws.Range("D2").Value = ws.Name
With ThisWorkbook.Worksheets("summary")
.Range("D2" & lastrow).Value = ws.Range("D18").Value
.Range("B2" & lastrow).Value = ws.Range("E8").Value
.Range("C2" & lastrow).Value = ws.Range("C12").Value
.Range("A2" & lastrow).Value = ws.Name
lastrow = lastrow + 1
End With
Next ws
wbdata.Save
wbdata.Close
Set wbdata = Nothing
Application.ScreenUpdating = True
MsgBox "Data transfer complete!", vbInformation, "Transfer Data"
End Sub[/VBA]

[omp001]

Try this:
1. add the dot and the word in red
[vba]lastrow = ThisWorkbook.Worksheets("summary").Range("A65536").End(xlUp).Offset(1, 0).Row
[/vba]
2. replace the lines below
[vba].Range("D2" & lastrow).Value = ws.Range("D18").Value
.Range("B2" & lastrow).Value = ws.Range("E8").Value
.Range("C2" & lastrow).Value = ws.Range("C12").Value
.Range("A2" & lastrow).Value = ws.Name
[/vba]
by these
[vba].Range("B" & lastrow).Value = ws.Range("B4").Value 'Data 1
.Range("C" & lastrow).Value = ws.Range("C12").Value 'Data 2
.Range("D" & lastrow).Value = ws.Range("E8").Value 'Data 3
.Range("E" & lastrow).Value = ws.Range("A22").Value 'Data 4
.Range("G" & lastrow).Value = ws.Range("G18").Value 'Data 5
.Range("H" & lastrow).Value = ws.Range("D18").Value 'Data 6
[/vba]

[tlchan]

Hi Osvald, The amended code dosen't work.

[omp001]

Hi, Tlcha.
Could you explain what you mean by 'doesn't work'?
It's not running...or
It runs but crashes? If so, what line is highlighted after you click on Debug? or
It runs but it not picks the correct data or/and it puts the data in other place than required...or what...

[tlchan]

Hi Osvaldo, the master remain blank.

[omp001]

Hi Tlchan.
It works fine for me.

The code I've used:

[vba]Sub Extract()
Dim wbdata As Workbook
Dim wbmaster As Workbook
Dim ws As Worksheet
Dim sFileName As String
Dim lastrow As Long

Application.ScreenUpdating = False
On Error Resume Next
sFileName = Application.GetOpenFilename
If sFileName = "False" Then Exit Sub
Set wbdata = Workbooks.Open(sFileName)
lastrow = ThisWorkbook.Worksheets("summary").Range("A65536").End(xlUp).Offset(1, 0).Row

For Each ws In wbdata.Worksheets
ws.Range("D2").Value = ws.Name
With ThisWorkbook.Worksheets("summary")
.Range("A" & lastrow).Value = ws.Range("D2").Value
.Range("B" & lastrow).Value = ws.Range("B4").Value 'Data 1
.Range("C" & lastrow).Value = ws.Range("C12").Value 'Data 2
.Range("D" & lastrow).Value = ws.Range("E8").Value 'Data 3
.Range("E" & lastrow).Value = ws.Range("A22").Value 'Data 4
.Range("G" & lastrow).Value = ws.Range("G18").Value 'Data 5
.Range("H" & lastrow).Value = ws.Range("D18").Value 'Data 6
lastrow = lastrow + 1
End With
Next ws

wbdata.Save
wbdata.Close
Set wbdata = Nothing
Application.ScreenUpdating = True
MsgBox "Data transfer complete!", vbInformation, "Transfer Data"
End Sub
[/vba]

[Simon Lloyd]

Change this line[VBA]lastrow = ThisWorkbook.Worksheets("summary").Range("A65536").End(xlUp).Offset(1, 0).Row [/VBA]for this line so it's compatible with all excel versions[VBA]lastrow = ThisWorkbook.Worksheets("summary").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row [/VBA]

[tlchan]

Thanks Osvaldo and simon. It works like a charm.