将其他工作表中的计算值填充到新工作表中

Question

我有包含四张纸的 excel(比如工作表 1、工作表 2、工作表 3 和工作表 4(。我想将计算值和其他信息从 (工作表 1， 工作表 2， 工作表 3( 填充到 工作表 4。工作表1，工作表2都包含ID，姓名，年龄，金额，而工作表1是静态页面，工作表2是动态页面。表3将有ID，姓名，年龄，贡献。输入所有这些值后，sheet4应填充ID，姓名，年龄，总计(金额*贡献(。

表 1：

+--------------------------+
| ID | Name | Age | Amount |
+--------------------------+
| 1  | AAAA | 20  | 1500   |
+--------------------------+
| 2  | BBBB | 21  | 2000   |
+--------------------------+
| 3  | CCCC | 25  | 6000   |
+--------------------------+

表 2：

+--------------------------+
| ID | Name | Age | Amount |
+--------------------------+
| 4  | XXXY | 20  | 3000   |
+--------------------------+
| 7  | YYYY | 21  | 7000   |
+--------------------------+
| 9  | ZZZZ | 25  | 5000   |
+--------------------------+

表 3：

此工作表贡献值将由用户输入，他们随机输入两个工作表(工作表 1 或工作表 2(中的任何用户

+------------------------------+
| ID | Name | Age | Contribute |
+------------------------------+
| 1  | AAAA | 20  | 1          |
+------------------------------+
| 3  | CCCC | 25  | 8          |
+------------------------------+
| 7  | YYYY | 21  | 9          |
+------------------------------+
| 9  | ZZZZ | 25  | 10         |
+------------------------------+

表 4：

这应该准确地自动填充 Sheet3 中的 ID、姓名和年龄，值应该是金额 * 贡献(根据 ID 来自工作表 1 或工作表 2 的金额(

+------------------------------+
| ID | Name | Age | Value      |
+------------------------------+
| 1  | AAAA | 20  | 1500       |
+------------------------------+
| 3  | CCCC | 25  | 48000      |
+------------------------------+
| 7  | YYYY | 21  | 63000      |
+------------------------------+
| 9  | ZZZZ | 25  | 50000      |
+------------------------------+

Answer 1

请尝试下一个代码。它必须复制到虚拟的"Sheet4"模块中。

您必须将"Sheet1_"、"Sheet2_"、"Sheet3_"工作表名称替换为您的真实名称。它还将清除已删除 ID 的所有记录：

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 Then
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, IDCell As Range
Dim dContrib As Double, dAmount As Double

Set sh1 = Worksheets("Sheet1_"): Set sh2 = Worksheets("Sheet2_")
Set sh3 = Worksheets("Sheet3_")

Set IDCell = sh3.Range("A:A").Find(What:=Target.Value, LookAt:=xlWhole)
If Not IDCell Is Nothing Then
If Target.Value <> "" Then
Target.Offset(0, 1).Value = IDCell.Offset(0, 1).Value
Target.Offset(0, 2).Value = IDCell.Offset(0, 2).Value
If IsNumeric(IDCell.Offset(0, 3).Value) Then
dContrib = IDCell.Offset(0, 3).Value
Else
'for the case of writing the ID header...
Target.Offset(0, 3).Value = "Value"
Exit Sub
End If
End If
Else
MsgBox """" & Target.Value & """ ID could not be found...": Target.Activate
Exit Sub
End If
Set IDCell = sh1.Range("A:A").Find(What:=Target.Value, LookAt:=xlWhole)
If Not IDCell Is Nothing Then
If Target.Value <> "" Then
dAmount = IDCell.Offset(0, 3).Value
Target.Offset(0, 3).Value = dAmount * dContrib: Exit Sub
End If
End If
Set IDCell = sh2.Range("A:A").Find(What:=Target.Value, LookAt:=xlWhole)
If Not IDCell Is Nothing Then
If Target.Value <> "" Then
dAmount = IDCell.Offset(0, 3).Value
Target.Offset(0, 3).Value = dAmount * dContrib: Exit Sub
End If
End If
If Target.Value <> "" Then
MsgBox """" & Target.Value & """ ID could not be found...": Target.Activate
Else
Target.Offset(0, 1).ClearContents: Target.Offset(0, 2).ClearContents
Target.Offset(0, 3).ClearContents
End If
End If
End Sub

编辑后：

请使用下一个代码。将下一个代码粘贴到 Sheet3 上存在的按钮的 Click 事件中：

Private Sub MyButton_Click()
Dim sh1 As Worksheet, sh2 As Worksheet, sh As Worksheet, sh4 As Worksheet
Dim dContrib As Double, dAmount As Double, IDCell As Range, Target As Range
Dim lastRow As Long, rngCopy As Range, i As Long

Set sh1 = Worksheets("Sheet1_"): Set sh2 = Worksheets("Sheet2_")
Set sh = ActiveSheet: Set sh4 = Worksheets("Sheet4_")

'Clear all the content of Sheet4, except its headers first row:
sh4.Range("A2:D" & sh4.Range("A" & Rows.Count).End(xlUp).row).ClearContents

'Copy all data from the first three columns of Sheet3:
Set rngCopy = sh.Range("A2:C" & sh.Range("A" & Rows.Count).End(xlUp).row)
sh4.Range("A2").Resize(rngCopy.Rows.Count, rngCopy.Columns.Count).Value = rngCopy.Value

'Iterate between all existing IDs and process the data:
lastRow = sh4.Range("A" & Rows.Count).End(xlUp).row
For i = 2 To lastRow
Set Target = sh.Range("A" & i) 'ID to be processed
dContrib = Target.Offset(0, 3).Value 'Amount

Set IDCell = sh1.Range("A:A").Find(What:=Target.Value, LookAt:=xlWhole)
If Not IDCell Is Nothing Then
If Target.Value <> "" Then
dAmount = IDCell.Offset(0, 3).Value
sh4.Range("D" & i).Value = dAmount * dContrib
End If
Else
Set IDCell = sh2.Range("A:A").Find(What:=Target.Value, LookAt:=xlWhole)
If Not IDCell Is Nothing Then
If Target.Value <> "" Then
dAmount = IDCell.Offset(0, 3).Value
sh4.Range("D" & i).Value = dAmount * dContrib
End If
End If
End If
Next i
sh4.Activate 'activate the processed sheet, in order to see the result
End Sub

Answer 2

您不需要工作表 4 来执行此操作。

工作表 1：将整个表保留在工作表 1 中

Sheet2：输入id并使用公式[=vlookup(A1，A1：D10,2,0(]在名称字段中，您需要名称的值。此处 2 是指列号。的表 1。这样您就可以使用公式是所有单元格。每当您更改 id 时，其余字段将自动填充。