在excel中合并两个文件中的数据并进行一些计算

Question

该项目包括根据来自 2 个不同表（或 Excel 文件）的值在新表中添加行。 有 3 个文件，由 :

调用

1. 参考：文件内容不会改变
2. 数据：文件的内容会一直变化
3. 结果：文件的内容是基于我下面的请求的参考和日期的组合。这是我需要的。 我创建了 3 个文件，所有这些文件都带有一些值，以帮助您理解，分别称为 Example_Reference、Example_Data 和 Example_Result。 要做什么：

第一步： 写一个新行（在新文件/表中）并准确复制参考文件第一行的所有单元格。

第二步： 我们获取参考文件的单元格（A 列）的内容（与点 1 相同的行），如果至少有一个单元格（A 列）完全相同，我们会在数据文件中查看：

一个。如果不是：什么都不做，继续参考文件的下一行（这样做直到参考行的行尾（不是 Excel 的结尾，但是当里面没有更多的行时））

b.如果是：

我。查看 A 列（数据文件）中有多少行具有相同的值（文本），创建（在结果文件中）与相同值的数量相等的行数并从数据文件中复制所有数据和行（对于当然是相同的 A 列）。 ii.在第一行（在第 1 点创建）中修改单元格（R 列），并在第 2.b 点添加列 R 的不同值。每行带有特定的“;”如示例所示。 （T1;T2;T3…如果 T1 T2 和 T3 在线）。

三。对于主线（在其中写入产品，如在参考文件和行中），在 N 列上，它应该是下面所有数字的总和（0、3 或 ???? 对于所有子行（变体）。 3. 如果 sum = 0，在 K 列写 FALSE。如果 sum 不为 0，在 K 列写 TRUE。

c。这样做直到我们读完参考文献的所有行

以下是示例三个文件的图片：

• 参考
• 数据
• 结果

到目前为止，我已经完成了第一步如下：

    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

现在我需要获取参考文件的单元格（A 列）的内容（与点 1 相同的行），如果至少有一个单元格（A 列）完全相同，我们会查看数据文件。

你们能帮忙吗？

我会随时更新我的​​问题...

Answer 1

这里有，如果按您的预期工作，请告诉我 :) 只需使用您的名称或路径设置工作簿变量。 潜艇已准备好与已打开的三个工作区一起工作，但如果 您希望宏打开 wbks，只需在开头添加 workbooks.open 方法即可。

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 2

请尝试下一个代码。我们看不到“参考”表的最后一列，但查看“结果”，我认为它应该是“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

如果涉及大文件/范围，我可以使用数组而不是所有范围来准备更快的解决方案。

已编辑

我找了一些时间，准备了更快的版本，只使用数组，所有处理都在内存中完成：

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

请进行测试并发送一些反馈。

Answer 3

已编辑：大声笑你改变了你的问题.. ;)

如果你喜欢用“选择”来制作所有东西，那么：

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

但是如果你有很多数据，你应该避免使用 select，因为它的性能非常慢。