[Many excels files Problem] Recover from multiple excels some values

[Arkine]

Hello everyone,

I have something I want to do, but I have no idea where to start, so here is the problem :
I have many excel files :
On the file a.xls I have this

Igor	10	20	10
Patrick	30	30	10
Bob	20	20	20

<tbody>
</tbody>

On the file b.xls I have this :

Igor	20	30	40
Bob	10	10	10
Edward	20	20	20

<tbody>
</tbody>

On the c.xls file, i would like to look into the a.xls file and the b.xls file to check the name, and then sum up the corresponding column :
It would give me in the end :

Igor	30	50	50
Patrick	30	30	10
Bob	30	30	30
Edward	20	20	20

<tbody>
</tbody>

(If there are some unique names between the excels it just retrieve the original values).
Is it possible to do so ? If yes thank you for your help It'd save me.

Thanks again,
Arkine

 

[Arkine]

*bump*
If anyone got an idea

 

[KeepTrying]

Hi Arkine,

I prepared a macro for you. Caveat:
- code doesn't have error handling so all values need to be number in input files ("a.xls" and "b.xls"), do not use "n/a" or "--" etc.
- in input files data must be in same structure (e.g. data start in cell A1)
- code first consolidates all data from input files then put them in summary file ("c.xls"). Then it summarizes all values per column in line with names
- sheet with data called "Sheet1" both in input files and in summary file

- add VBA code below to summary file ("c.xls") to a standard module then run. Input files must be closed before run code.

Option Explicit

Sub MainCode02()

Dim FileLocation As String, FileName As String, Lap As Worksheet, X
Dim i As Long, j As Long, D As Object, Rng As Range, Ertek1, Ertek2, Ertek3
Dim Adat1(), Adat2(), Adat3()

'Source: _
https://www.mrexcel.com/forum/excel-questions/1018264-[many-excels-files-problem]-recover-multiple-excels-some-values.html

Application.ScreenUpdating = False

'clear "Sheet1"
ThisWorkbook.Worksheets("Sheet1").Cells.Clear 'change sheet name if necessary

'copy data from input files (in "a.xls" and "b.xls") to summary file ("c.xls")
FileLocation = ThisWorkbook.Path & "\" 'input files has to be in same folder as summary file
FileName = Dir(FileLocation & "*xls")
X = 1
Do Until FileName = ""
    If FileName <> ThisWorkbook.Name Then
        Workbooks.Open (FileLocation & FileName)
            For Each Lap In ActiveWorkbook.Worksheets
                If Lap.Name = "Sheet1" Then 'assuming sheet name with data called "Sheet1" in input files (in "a.xls" and "b.xls")
                    Lap.UsedRange.Copy ThisWorkbook.Worksheets("Sheet1").Cells(X, 1) 'copy input data to "Sheet1" in summary file ("c.xls")
                    X = X + Lap.UsedRange.Rows.Count
                    Exit For
                End If
            Next Lap
        Workbooks(FileName).Close
    End If
    FileName = Dir()
Loop
'-----------------------------------------------------


'get summary results per name for each column
Set Rng = ThisWorkbook.Worksheets("Sheet1").UsedRange 'change sheet name if necessary
Set D = CreateObject("scripting.dictionary")


'get unique name list
For i = 1 To Rng.Rows.Count
    D(CStr(Rng.Cells(i, 1))) = ""
Next i


X = D.keys
For i = 0 To D.Count - 1
    Ertek1 = ""
    Ertek2 = ""
    Ertek3 = ""
    For j = 1 To Rng.Rows.Count
        If X(i) = Rng.Cells(j, 1) Then
            If Ertek1 = "" Then Ertek1 = Rng.Cells(j, 2) Else Ertek1 = Ertek1 + Rng.Cells(j, 2) 'get summary per name in column "B"
            ReDim Preserve Adat1(i)
            Adat1(i) = Ertek1


            If Ertek2 = "" Then Ertek2 = Rng.Cells(j, 3) Else Ertek2 = Ertek2 + Rng.Cells(j, 3) 'get summary per name in column "C"
            ReDim Preserve Adat2(i)
            Adat2(i) = Ertek2
            
            If Ertek3 = "" Then Ertek3 = Rng.Cells(j, 4) Else Ertek3 = Ertek3 + Rng.Cells(j, 4) 'get summary per name in column "D"
            ReDim Preserve Adat3(i)
            Adat3(i) = Ertek3
        End If
    Next j
Next i


'-------------------
'write names on "Sheet1"
j = 1
For i = 0 To D.Count - 1
    ThisWorkbook.Worksheets("Sheet1").Cells(j, 6) = X(i)
    j = j + 1
Next i


'write summary results per name on "Sheet1" for columns
j = 1
For i = LBound(Adat1) To UBound(Adat1)
    ThisWorkbook.Worksheets("Sheet1").Cells(j, 7) = Adat1(i)
    ThisWorkbook.Worksheets("Sheet1").Cells(j, 8) = Adat2(i)
    ThisWorkbook.Worksheets("Sheet1").Cells(j, 9) = Adat3(i)
    j = j + 1
Next i


Application.ScreenUpdating = True


End Sub

After code successfully ran you'll see output in range F1:I4 with same result as you showed in your post.

Kind Regards,

 

[Arkine]

Thanks so much for your help KeepTrying !

Had some troubles making this to work, but it finally works

Thanks again !

Arkine

 

[KeepTrying]

You're welcome I can refine the code if you tell me what's your request.