Combine Data from two files in excel and do some calculation

Question

The project consist to add lines in a new table based on value coming from 2 different table (or Excel file). There are 3 files, called by :

1. Reference : the content of the file will not change
2. Data : the content of the file will always change
3. Result : the content of the file is a combination of the Reference and Date based on my request below. It is want I need. I create 3 files, all manually with some value in order to help you to understand, called Example_Reference, Example_Data and Example_Result. What as to be done:

First step: Write a new line (in the new file/table) and copy exactly all the cells of the first line of Reference file.

Second step: We take the content of the cell (column A) of Reference file (same line that point 1.) and we look in the Data file if one cell at least (column A) is the exactly the same :

a. If NOT : Do nothing, and continue for next line of the Reference file (do that until end of line of the Reference line (not end of Excel, but when no more line with something inside))

b. If YES :

i. Look how many line are with the same value (text) in the column A (Data file), create (in the Result file) a number of line equal to the number of same value and copy all data and line from Data file (for the same Column A of course). ii. Modify in the first line (created on point 1) the cell (column R) with the different value of the column R added in point 2.b. of each line with specific “;” as in example. (T1;T2;T3… if T1 T2 and T3 are on the line).

iii. For main line (where a Product is written, like in the Reference file and line), on column N, it should be the sum of all the number below (0, 3 or 😎 for all the subline (Variant). 3. If sum = 0, write FALSE on column K. If sum is different from 0, write on column K TRUE.

c. Do that until we finish to read all the line of the Reference

Below are the Images of example three files:

• Reference
• Data
• Result

So far I have done with the First Step as follows:

    Dim cel As Range
    Dim oFoundRng As Range

Range("A1").End(xlUp).Select ' looking for first empty cell on result sheet

With Workbooks("Example_Reference").Worksheets("Feuil1")
With .Range("a1", .Cells(.Rows.Count, "a").End(xlUp))
    For Each cel In .SpecialCells(xlCellTypeConstants) ' loop through referenced range not empty cells
    
.Range(cel.Address).EntireRow.Copy Workbooks("result").Worksheets("feuil1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    
    
    Next
End With
End With

Now I need to take the content of the cell (column A) of Reference file (same line that point 1.) and we look in the Data file if one cell at least (column A) is the exactly the same.

can you guys help?

I will update my question as I go along ...

Answer 1

Try the next code, please. We cannot see which is the last column of 'Reference' sheet, but looking to the 'Result' one I assumed that it should be column "Q:Q":

Sub testProcessThreeWorkbooks()
 Dim wsRef As Worksheet, wsData As Worksheet, wsRes As Worksheet
 Dim lastRR As Long, lastRD As Long, rowRes As Long, i As Long, j As Long
 Dim count As Long, k As Long, arr, arrT
 
 Set wsRef = Workbooks("Example_Reference.xlsx").Sheets(1) 'use here the necessary sheet
 Set wsData = Workbooks("Example_Data.xlsx").Sheets(1)     'use here the necessary sheet
 Set wsRes = Workbooks("Example_Result.xlsx").Sheets(1)    'use here the necessary sheet
  lastRR = wsRef.Range("A" & rows.count).End(xlUp).row     'last row of 'Reference` sheet
  lastRD = wsData.Range("A" & rows.count).End(xlUp).row    'last row of 'Data' sheet
  rowRes = 1 'Row of the 'Result' sheet, where the first processed line should be placed
  
  For i = 1 To lastRR 'iterate between all existing cells of A:A 'Reference' sheet column
    wsRes.Range("A" & rowRes).Resize(1, 17).Value = wsRef.Range("A" & i, "Q" & i).Value 'copy the row to be processed
    count = WorksheetFunction.CountIf(wsData.Range("A1:A" & lastRD), wsRef.Range("A" & i).Value) 'count the occurrences
    If count > 0 Then 'if any occurence exists:
        ReDim arrT(count - 1) 'redim the array keeping 'T' type data
        ReDim arr(count - 1)  'redim the array to keep the values from C:C column
        k = 0                 'initialize the variable to fill in the above arrays
        For j = 1 To lastRD   'iterate between all existing cells of A:A 'Data' sheet column
            If wsRef.Range("A" & i).Value = wsData.Range("A" & j).Value Then 'for occurrences:
                arrT(k) = wsData.Range("B" & j).Value           'load 'T' type values
                arr(k) = wsData.Range("C" & j).Value: k = k + 1 'Load values of C:C column
            End If
        Next j
        With wsRes 'process the 'Result' range:
            .Range("R" & rowRes).Value = Join(arrT, ";") 'place the string in column R:R
            .Range("A" & rowRes + 1 & ":A" & rowRes + count).Value = wsRef.Range("A" & i).Value 'copy the 'Codes'
            .Range("B" & rowRes + 1 & ":B" & rowRes + count).Value = "Variant"                  'write 'Variant'
            .Range("N" & rowRes + 1).Resize(UBound(arr) + 1, 1).Value = WorksheetFunction.Transpose(arr) 'drop the array values
            .Range("N" & rowRes).Formula = "=Sum(N" & rowRes + 1 & ":N" & rowRes + count & ")"  'sumarize the values of N:N col
            'Evaluate the value in N:N and place 'TRUE' or 'FALSE' accordingly:
            If .Range("N" & rowRes).Value = 0 Then .Range("K" & rowRes).Value = False Else: .Range("K" & rowRes).Value = True
        End With
    End If
    rowRes = rowRes + count + 1: count = 0 'reinitialize the necessary variables
  Next i
End Sub

If big files/ranges are involved, I can prepare a faster solution using arrays instead of all ranges.

Edited

I found some time and prepared the faster version, using only arrays, all processing being done in memory:

Sub testProcessThreeWorkbooksArrays()
 Dim wsRef As Worksheet, wsData As Worksheet, wsRes As Worksheet
 Dim lastRR As Long, lastRD As Long, rowRes As Long, i As Long, j As Long
 Dim count As Long, k As Long, arrRef, arrDat, arrRes, arrSlice, arr, arrT
 Dim m As Long, sumV As Double
 
 Set wsRef = Workbooks("Example_Reference.xlsx").Sheets(1) 'use here the necessary sheet
 Set wsData = Workbooks("Example_Data.xlsx").Sheets(1)     'use here the necessary sheet
 Set wsRes = Workbooks("Example_Result.xlsx").Sheets(1)    'use here the necessary sheet
  lastRR = wsRef.Range("A" & rows.count).End(xlUp).row     'last row of 'Reference` sheet
  lastRD = wsData.Range("A" & rows.count).End(xlUp).row    'last row of 'Data' sheet
  
  arrRef = wsRef.Range("A1:Q" & lastRR).Value
  arrDat = wsData.Range("A1:C" & lastRD).Value
  ReDim arrRes(1 To 18, 1 To UBound(arrRef) + UBound(arrDat))
  rowRes = 1 'Row of the 'Result' sheet, where the new processed line should be placed
  
  For i = 1 To UBound(arrRef) 'iterate between all existing 'arrRef' array rows
    arrSlice = Application.Index(arrRef, i, 0) 'extract a slice of the row number i
    'Place the slice values in the arrRes appropriate row:
    For m = 1 To UBound(arrSlice): arrRes(m, rowRes) = arrSlice(m): Next m
    arrSlice = Application.Index(arrDat, 0, 1) 'extract a slice of the 'arrDat' first column

    For m = 1 To UBound(arrSlice)
        If arrSlice(m, 1) = arrRef(i, 1) Then count = count + 1 'extract number of occurrences
    Next m
    If count > 0 Then         'if any occurence exists:
        ReDim arrT(count - 1) 'redim the array keeping 'T' type data
        ReDim arr(count - 1)  'redim the array to keep the values from C:C column
        k = 0                 'initialize the variable to fill in the above arrays
        For j = 1 To UBound(arrDat)   'iterate between all 'arrDat' array rows:
            If arrRef(i, 1) = arrDat(j, 1) Then  'in case of occurrences:
                arrT(k) = arrDat(j, 2)           'load 'T' type values
                arr(k) = arrDat(j, 3): k = k + 1 'Load values of C:C column
            End If
        Next j
        arrRes(18, rowRes) = Join(arrT, ";") 'place the string in column R:R
        For m = rowRes + 1 To rowRes + count
            'place the code ("A:A" content) and "Variant" string:
            arrRes(1, m) = arrRef(i, 1): arrRes(2, m) = "Variant"
        Next m
        For m = 0 To UBound(arr)  'place the values in the 14th column
            arrRes(14, rowRes + m + 1) = arr(m)
            sumV = sumV + arr(m)  'calculate the values Sum
        Next m
        arrRes(14, rowRes) = sumV 'place the Sum in the 14th array column
        If sumV > 0 Then arrRes(11, rowRes) = True Else: arrRes(11, rowRes) = False 'True/False
    End If
    rowRes = rowRes + count + 1: count = 0: sumV = 0 'reinitialize the necessary variables
  Next i
  ReDim Preserve arrRes(1 To 18, 1 To rowRes - 1) 'keep only the non empty array elements
  wsRes.Range("A1").Resize(UBound(arrRes, 2), UBound(arrRes)).Value = Application.Transpose(arrRes)
  MsgBox "Ready..."
End Sub

Please, test it and send some feedback.

Answer 2

Here you have, let me know if works as you expected :) Just set the workbook variables with your names or paths. The sub is ready to work with the three workboos already opened but if you want the macro to open the wbks just add workbooks.open method at the beginning.

Sub ProcessData()
    
    'Workbook ans worksheet declaration
    Dim referenceWbk As Workbook
    Set referenceWbk = Workbooks("Reference.xlsx")
    Dim dataWbk As Workbook
    Set dataWbk = Workbooks("Data.xlsx")
    Dim exampleWbk As Workbook
    Set exampleWbk = Workbooks("Example.xlsm")
       
    Dim referenceWsh As Worksheet
    Set referenceWsh = referenceWbk.Sheets(1)
    Dim dataWsh As Worksheet
    Set dataWsh = dataWbk.Sheets(1)
    Dim exampleWsh As Worksheet
    Set exampleWsh = exampleWbk.Sheets(1)
    
    'Loop reference workbook
    Dim exampleLastRow As Long: exampleLastRow = 1
    
    Dim i As Long
    For i = 1 To referenceWsh.Range("A" & referenceWsh.Rows.Count).End(xlUp).Row
        referenceWsh.Range("A" & i).EntireRow.Copy
        exampleWsh.Range("A" & exampleLastRow).PasteSpecial xlPasteValues
        
        'loop data wsh
        Dim coicidenceCount As Long: coicidenceCount = 0
        'Delete header in column N, R and K
        exampleWsh.Range("N" & exampleLastRow).Value = ""
        exampleWsh.Range("R" & exampleLastRow).Value = ""
        exampleWsh.Range("K" & exampleLastRow).Value = ""
        
        Dim j As Long
        For j = 1 To dataWsh.Range("A" & dataWsh.Rows.Count).End(xlUp).Row
            If dataWsh.Range("A" & j).Value = exampleWsh.Range("A" & exampleLastRow).Value Then
                coicidenceCount = coicidenceCount + 1
                exampleWsh.Range("A" & exampleLastRow + coicidenceCount).Value = dataWsh.Range("A" & j).Value
                exampleWsh.Range("R" & exampleLastRow + coicidenceCount).Value = dataWsh.Range("B" & j).Value
                exampleWsh.Range("N" & exampleLastRow + coicidenceCount).Value = dataWsh.Range("C" & j).Value
                exampleWsh.Range("B" & exampleLastRow + coicidenceCount).Value = "Variant"
                
                'add value to R header (plus ';')
                exampleWsh.Range("R" & exampleLastRow).Value = exampleWsh.Range("R" & exampleLastRow).Value & dataWsh.Range("B" & j).Value & ";"
                'add value to N header
                exampleWsh.Range("N" & exampleLastRow).Value = exampleWsh.Range("N" & exampleLastRow).Value + dataWsh.Range("C" & j).Value
            End If
        Next j
        
            'add value to K header
            If exampleWsh.Range("N" & exampleLastRow).Value > 0 Then
                exampleWsh.Range("K" & exampleLastRow).Value = True
            Else
                exampleWsh.Range("K" & exampleLastRow).Value = False
            End If
            
            'delete last ';' from R header
            If exampleWsh.Range("R" & exampleLastRow).Value <> "" Then
            exampleWsh.Range("R" & exampleLastRow).Value = Left(exampleWsh.Range("R" & exampleLastRow).Value, Len(exampleWsh.Range("R" & exampleLastRow).Value) - 1)
            End If
            
            exampleLastRow = exampleWsh.Range("A" & exampleWsh.Rows.Count).End(xlUp).Row + 1
                
    Next i
    End Sub

Answer 3

Edited: lol you changed your question.. ;)

If you like make everything with "Select" then:

Sub Macro1()

Set ref = Workbooks("book1").Sheets("sheet1")
Set res = Workbooks("book2").Sheets("sheet2")

ref.Rows("6:6").Copy
res.Activate
res.Rows("9:9").Select
ActiveSheet.Paste
End Sub

But you should avoid using select if you will have a lot of data, as its perfomance is slow as hell.