Extract data from different Excelfiles or worsheets

[MarcoNun]

I hope somebody can help me and thank you in advance!!

My problem is that I have around 20 Excelfiles each of them has around 15 Worksheets. Now I would like to extract certain values in order to make calculations and finally to build graphs and diagrams. the value is written next to the descripiton which is common. With copy and paste I get crazy.

How can I automatize it that I can scan Excel files and worksheets for certain values (e.g. total production volume).

Thank you very much!

 

[stanleydgromjr]

Part 2

Part 2

After the macro:

Summary for MarcoNun.xls
	A	B	C	D	E	F	G
1	FileName	Category	Volume		TestDataFilesContain
2	Alpha	ProductionA	100		FileName	Category	Volume
3	Beta	ProductionB	200
4	Charlie	ProductionA	300		Alpha	OperationalData!
5	Dog	ProductionA	400		A1	ProductionA
6	Echo	ProductionB	500		A2	100
7
8					Beta	OperationalData!
9					A1	ProductionB
10					A2	200
11
12					Charlie	OperationalData!
13					A1	ProductionA
14					A2	300
15
16					Dog	OperationalData!
17					A1	ProductionA
18					A2	400
19
20					Echo	OperationalData!
21					A1	ProductionB
22					A2	500
23
24					ExpectedResults
25					Alpha	ProductionA	100
26					Beta	ProductionB	200
27					Charlie	ProductionA	300
28					Dog	ProductionA	400
29					Echo	ProductionB	500
Summary

 

[MarcoNun]

Problem resolved

Thank you Stan and Ravishankar!

I modified a little bit the Makro and it works!

This was a great help and actually motivates me also to study more Viual Basic.

Again Thank you!
Marco

 

[stanleydgromjr]

Part 3 - code

Part 3 - code


Please TEST this FIRST in a COPY of your workbook.

Press and hold down the 'ALT' key, and press the 'F11' key.

Insert a Module in your VBAProject, Microsoft Excel Objects

Copy the below code, and paste it into the Module1.

Option Explicit
Sub CreateSummary()
'
'CreateSummary Macro
'Macro updated/created 08/05/2007 by Stanley D. Grom, Jr.
'
'Original code from:
'VBA & Macros for Microsoft Excel by Bill Jelen & Tracy Syrstad
'CombineWorkbooks()
'Page 300
'
    Dim CurFile As String
    Dim DestWB As Workbook
    Dim ws As Object 'allows for different sheet types
    Dim lngSummaryLastRow As Long

    '********************************************************************************************
    'Change the "C:\Data\" within the quote marks to the full path for the location of your files
    '  and do not forget to add the ending backslash \
    '
    Const DirLoc As String = "C:\Data\"

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set DestWB = ActiveWorkbook
    Sheets("Summary").Select
    lngSummaryLastRow = Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Row + 1
    CurFile = Dir(DirLoc & "*.xls")
    
    'I have in Excel file Alpha.xls and in the Worksheet "Operational Data"
    'A1: Production
    'A2: 200
    Do While CurFile <> vbNullString
        Dim OrigWB As Workbook
        Set OrigWB = Workbooks.Open(Filename:=DirLoc & CurFile, ReadOnly:=True)
        'Limits to valid sheet names and removes ".xls"
        CurFile = Left(Left(CurFile, Len(CurFile) - 4), 29)
        For Each ws In OrigWB.Sheets
            If ws.Name = "Operational Data" Then
                DestWB.Sheets("Summary").Range("A" & lngSummaryLastRow) = CurFile
                DestWB.Sheets("Summary").Range("B" & lngSummaryLastRow) = ws.Range("A1")
                DestWB.Sheets("Summary").Range("C" & lngSummaryLastRow) = ws.Range("A2")
            End If
        Next
        OrigWB.Close SaveChanges:=False
        CurFile = Dir
        lngSummaryLastRow = lngSummaryLastRow + 1
    Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Make sure you change the full path in the above code code - see the note above the code:

    Const DirLoc As String = "C:\Data\"

Please TEST this FIRST in a COPY of your workbook.

Then run the 'CreateSummary' macro.

Have a great day,
Stan

 

[MarcoNun]

Thank you , Stan.
But that looks definitly more complicated, I will need some more time to understand it.

I have at the moment the problem that I noticed that some people who updated the data changed the cell. So I don't know if the value that interest me is in A1 and A2 (just to simplify).

Do you know how I have to modify the makro below when I don't know where Production is. Let's say I know it is the column A but not in which row.

How do I write: check column A and tell me where is "Production" and take the value right next to it??

Sorry for all the question, but probably alone I need two weeks to get it.
So thank you again!

EXAMPLE:
I have in Excel file Alpha.xls and in the Worksheet "Operational Data"
A1: Production
A2: 200

I have in Excel file Beta.xls and in the Worksheet "Operational Data"
A1: Production
A2: 500

MAKRO
---------------------------------------------------------------------------
Sub hhh()
Cells(1, 1).Select
f = Dir("C:\" & "*.xls")
Do While Len(f) > 0
ActiveCell.Formula = f
ActiveCell.Offset(1, 0).Select
f = Dir()
n = n + 1
Loop
x = Worksheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For a = 1 To x
h = Cells(a, 1)
Cells(a, 2) = "='C:\[" & h & "]sheet1'!A1"
Cells(a, 3) = "='C:\[" & h & "]sheet1'!A2"
Next a
End Sub

 

[tomas_eduarte]

almost the same problem.... please help..

hi stan. i have also a problem that is similar to macronun.
my problem is that i want to open multiple excel files, then copy values of a10 up to the last cell (xldown) then paste it on the last nonblank cell in column c. then close the file (source file) and open another file. can this be done? thanks in advance

 

[jindon]

try

Sub test()
Dim myDir As String, fn As String
myDir = "C:\"
fn = Dir(myDir & "*.xls")
Do While fn <> ""
     With Workbooks.Open(myDir & fn)
          With .Sheets("Operational Data")
               With .Range("a10",.Range("a" & Rows.Count).end(xlUp))
                    ThisWorkbook.Sheets(1).Range("a" & Rows.Count).End(xlUp) _
                    .Offset(1).Resize(.Rows.Count).Value = .Value
               End With
          End With
          .Close False
     End With
     fn = Dir()
Loop
End Sub