PDA

View Full Version : Solved: Summary Extracted Data from multiple sheets from Different workbook



tlchan
12-08-2012, 11:30 PM
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
12-09-2012, 10:13 AM
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 themSub Loop_thru_Sheets()
Dim Sh As Worksheet
For each Sh in Sheets
'YOUR WORKING CODE HERE
Next Sh
End SubYou 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
12-10-2012, 07:12 AM
Thanks Simon. I hope you may help me out as I am still lost to get it work around.

tlchan
12-15-2012, 12:02 AM
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


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

omp001
12-15-2012, 06:47 PM
Try this:
1. add the dot and the word in red
lastrow = ThisWorkbook.Worksheets("summary").Range("A65536").End(xlUp).Offset(1, 0).Row

2. replace the lines below
.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

by these
.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

tlchan
12-17-2012, 08:08 AM
Hi Osvald, The amended code dosen't work.

omp001
12-17-2012, 10:26 AM
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
12-18-2012, 07:31 AM
Hi Osvaldo, the master remain blank.

omp001
12-18-2012, 08:49 AM
Hi Tlchan.
It works fine for me.

The code I've used:

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

Simon Lloyd
12-18-2012, 10:47 AM
Change this linelastrow = ThisWorkbook.Worksheets("summary").Range("A65536").End(xlUp).Offset(1, 0).Row for this line so it's compatible with all excel versionslastrow = ThisWorkbook.Worksheets("summary").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row

tlchan
12-21-2012, 07:06 AM
Thanks Osvaldo and simon. It works like a charm.