Excel 将其他图纸中的计算值填充到新图纸中_Excel_Vba_Excel Formula

Excel 将其他图纸中的计算值填充到新图纸中

excel vba excel-formula

Excel 将其他图纸中的计算值填充到新图纸中,excel,vba,excel-formula,Excel,Vba,Excel Formula,我有excel，其中包含四张表（如表1、表2、表3和表4）。我想将计算值和其他信息从（表1、表2、表3）填充到表4。sheet1、sheet2都包含ID、姓名、年龄和金额，而sheet1是静态页面，sheet2是动态页面。表3将包含ID、姓名、年龄和贡献。输入所有这些值后，sheet4应填写ID、姓名、年龄、总计（金额*供款）第1页： +--------------------------+ | ID | Name | Age | Amount | +---------------------

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

第1页：

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

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

第2页：

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

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

第3页：

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

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

该图纸贡献值将由用户输入，用户可从两张图纸（图纸1或图纸2）中为任何用户随机输入

第4页：

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

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

这应该是从Sheet3自动准确填写ID、姓名和年龄，值应该是Amount*Contribution（我的金额来自sheet1或sheet2，基于ID）

您不需要第4页来执行此操作

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

Sheet2：输入id并在需要名称值的名称字段中使用公式[=vlookup（A1，A1:D10,2,0）]。此处2指第1页的列号。通过这种方式，您可以使用所有单元格的公式。无论何时更改id，其余字段都将自动填充。

请尝试下一个代码。必须将其复制到虚拟“Sheet4”模块中

您必须将“Sheet1_uu”、“Sheet2_uu”、“Sheet3_uuu”工作表名称替换为您的真实工作表名称。它还将清除已删除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

选项显式
私有子工作表_更改（ByVal目标作为范围）
如果Target.Column=1，则
尺寸sh1作为工作表，sh2作为工作表，sh3作为工作表，IDCell作为范围
Dim dContrib为双精度，dAmount为双精度
设置sh1=工作表（“图纸1”）：设置sh2=工作表（“图纸2”）
设置sh3=工作表（“表3”）
设置IDCell=sh3.Range（“A:A”）.Find（What:=Target.Value，LookAt:=xlWhole）
如果不是，那么IDCell什么都不是
如果Target.Value为“”，则
Target.Offset（0,1）.Value=IDCell.Offset（0,1）.Value
Target.Offset（0,2）.Value=IDCell.Offset（0,2）.Value
如果是数字（IDCell.Offset（0,3）.Value），则
dContrib=IDCell.Offset（0,3）.Value
其他的
'对于写入ID标头的情况。。。
Target.Offset（0,3）.Value=“Value”
出口接头
如果结束
如果结束
其他的
找不到MsgBox“”&Target.Value&“ID…”：Target.Activate
出口接头
如果结束
设置IDCell=sh1.Range（“A:A”）.Find（What:=Target.Value，LookAt:=xlother）
如果不是，那么IDCell什么都不是
如果Target.Value为“”，则
dAmount=IDCell.Offset（0,3）.Value
Target.Offset（0,3）.Value=dAmount*dContrib:Exit Sub
如果结束
如果结束
设置IDCell=sh2.Range（“A:A”）.Find（What:=Target.Value，LookAt:=xlWhole）
如果不是，那么IDCell什么都不是
如果Target.Value为“”，则
dAmount=IDCell.Offset（0,3）.Value
Target.Offset（0,3）.Value=dAmount*dContrib:Exit Sub
如果结束
如果结束
如果Target.Value为“”，则
找不到MsgBox“”&Target.Value&“ID…”：Target.Activate
其他的
Target.Offset（0,1）.ClearContents:Target.Offset（0,2）.ClearContents
Target.Offset（0,3）.ClearContents
如果结束
如果结束
端接头

编辑后：

请使用下一个代码。在Sheet3上现有按钮的单击事件中粘贴下一个代码：

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

Private Sub MyButton\u Click（）
尺寸sh1作为工作表，sh2作为工作表，sh作为工作表，sh4作为工作表
Dim dContrib为双精度，dAmount为双精度，IDCell为范围，目标为范围
调暗最后一行的长度，rngCopy的范围，i的长度
设置sh1=工作表（“图纸1”）：设置sh2=工作表（“图纸2”）
设置sh=活动工作表：设置sh4=工作表（“工作表4”）
'清除Sheet4中除第一行标题以外的所有内容：
sh4.Range（“A2:D”和sh4.Range（“A”和Rows.Count）.End（xlUp.row）.ClearContents
'从Sheet3的前三列复制所有数据：
设置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
'在所有现有ID之间迭代并处理数据：
lastRow=sh4.Range（“A”&Rows.Count）.End（xlUp）.row
对于i=2到最后一行
设置要处理的目标=sh.Range（“A”&i）”ID
dContrib=Target.Offset（0,3）.Value'金额
设置IDCell=sh1.Range（“A:A”）.Find（What:=Target.Value，LookAt:=xlother）
如果不是，那么IDCell什么都不是
如果Target.Value为“”，则
dAmount=IDCell.Offset（0,3）.Value
sh4.Range（“D”和i）.Value=dAmount*dContrib
如果结束
其他的
设置IDCell=sh2.Range（“A:A”）.Find（What:=Target.Value，LookAt:=xlWhole）
如果不是，那么IDCell什么都不是
如果Target.Value为“”，则
dAmount=IDCell.Offset（0,3）.Value
sh4.Range（“D”和i）.Value=dAmount*dContrib
如果结束
如果结束
如果结束
接下来我
sh4.激活“激活已处理的工作表，以查看结果
端接头

请在您的问题中包括您尝试过的内容。您想要

VLOOKUP

：@braX我是VBA新手，我也尝试使用少量的知识来源。“Sheet3”

贡献是每个ID
都是唯一的，还是需要对其进行总结，以了解更多可能出现的情况？我的意思是，是否有更多（相同）ID具有不同的贡献
，需要进行总结？@FaneDuru Yes“Sheet3”贡献
是每个ID
唯一的。只有一个<鳕鱼