请VBA大神帮忙

蜗牛等我

附件有两个工作簿 “编号登记表”和“COC of 123 UTC2020001”，我要实现的功能是：

在工作簿 “编号登记表”的工作表“CoC No.交付资料”中插入一个按钮，输入合格证号“UTC2020001”后，就可以把工作簿 “编号登记表”的工作表“COC of”复制出来，另存为工作表“COC of 123 UTC2020001”，同时这个工作表中有“CoC No.交付资料”中的相关数据。

3190496160

COC of工作表中红色字体部分应该是需要通过编号来匹配的吧】

蜗牛等我

3190496160 发表于 2023-5-19 17:21
COC of工作表中红色字体部分应该是需要通过编号来匹配的吧】

是的，红色字体对应的是第一个表的内容

3190496160

Private Sub CommandButton1_Click()
Dim rn As Range
zd = ComboBox1.Text
If zd = "" Then MsgBox "请输入字段名称！": Exit Sub
With Sheets("CoC No.交付资料")
    r = .Cells(Rows.Count, 5).End(xlUp).Row
    ar = .Range("a1:t" & r)
    Set rn = .Range("e1:e" & r).Find(zd, , , , , , 1)
End With
If rn Is Nothing Then Exit Sub
xh = rn.Row
With Sheets("COC of")
    .[i2] = zd
    .[a8] = ar(xh, 13)
    .[g8] = ar(xh, 15)
    .[b16] = ar(xh, 3)
    .[d18] = ar(xh, 2)
    .[d19] = "Revision:" & ar(xh, 4)
    .[e19] = ar(xh, 6)
    .[i16] = ar(xh, 8)
    .[a22] = ar(xh, 13)
    .[e23] = ar(xh, 12)
    .[e24] = ar(xh, 14)
    .[d30] = ar(xh, 7)
    .Copy
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\COC of 123" & zd & ".xlsx"
End With
ActiveWorkbook.Close
End
End Sub

Private Sub UserForm_Initialize()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("CoC No.交付资料")
    r = .Cells(Rows.Count, 5).End(xlUp).Row
    If r < 2 Then MsgBox "CoC No.交付资料为空！": End
    ar = .Range("e1:e" & r)
End With
For i = 2 To UBound(ar)
    If Trim(ar(i, 1)) <> "" Then
        d(Trim(ar(i, 1))) = ""
    End If
Next i
Me.ComboBox1.List = d.keys
End Sub

3190496160

合格证.rar (50.57 KB, 下载次数: 5)

2023-5-19 21:56 上传

点击文件名下载附件

3190496160

没有任何的具体说明，只能根据公式来写代码，没有公式额地方就没办法了，所以，代码仅供参考

蜗牛等我

3190496160 发表于 2023-5-19 21:56
没有任何的具体说明，只能根据公式来写代码，没有公式额地方就没办法了，所以，代码仅供参考

好的，谢谢，这个代码很好用