怎么使用VBA一件开合格证

蜗牛等我 · 发表于 2024-9-18 22:08

附件有3个工作簿 “登记表” “A-2024105-123” “2024206-123”，我要实现的功能是：

在工作簿 “登记表”的工作表 “登记” 中插入2个按钮：
点击第1个按钮功能，输入“合格证编号”后，就可以把工作簿 “登记表”的工作表 “COC ” 复制出来，另存为工作表“2024206-123”（合格证-图号），同时这个“2024206-123”中复制了工作簿 “登记表”的工作表 “登记” 中的相关数据。

点击第2个按钮功能，输入 “表1编号” 后，就可以把工作簿 “登记表”的工作表 “FORM1 ” 复制出来，另存为工作表“A-2024105-123”（表1-图号），同时这个“A-2024105-123”表中复制了工作簿 “登记表”的工作表 “登记” 中的相关数据。

ykcbf1100 · 发表于 2024-9-19 08:05

写了一个，按合格证编号另存

ykcbf1100 · 发表于 2024-9-19 08:05

合格证编号另存

Sub ykcbf() '//2024.9.19
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("Scripting.Dictionary")
fn = [{"COC","登记"}]
With Sheets("COC")
s = .[l2].Value
d(s) = Array(.[d22].Value, .[d7].Value, .[c7].Value, "2023-1", .[j7].Value, .[f7].Value, .[l5].Value, .[m5].Value, .[k7].Value)
End With
With Sheets("登记")
s = .Cells(2, "i").Value
If d.exists(s) Then
.Cells(2, 2) = d(s)(0)
.Cells(2, 3) = d(s)(1)
.Cells(2, 4) = d(s)(2)
.Cells(2, 5) = d(s)(3)
.Cells(2, 6) = d(s)(4)
.Cells(2, 7) = d(s)(5)
.Cells(2, "o") = d(s)(6)
.Cells(2, "p") = d(s)(7)
.Cells(2, "t") = d(s)(8)
End If
End With
Worksheets(fn).Copy
Set wb = ActiveWorkbook
wb.Sheets("登记").DrawingObjects.Delete
wb.SaveAs Filename:=ThisWorkbook.Path & "" & s & "-123.xlsx", FileFormat:=51
wb.Close
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

ykcbf1100 · 发表于 2024-9-19 08:16

本帖最后由 ykcbf1100 于 2024-9-19 08:19 编辑

另一个也写了，按表1编号另存

ykcbf1100 · 发表于 2024-9-19 08:17

按表1编号另存

Sub ykcbf2() '//2024.9.19 表1编号
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("Scripting.Dictionary")
fn = [{"FORM1","登记"}]
With Sheets("FORM1")
s = .[j4].Value
d(s) = Array(.[f25].Value, .[e11].Value, .[c11].Value, "2023-1", .[g11].Value, .[h11].Value, .[j8].Value, .[b13].Value)
End With
With Sheets("登记")
s = .Cells(2, "j").Value
If d.exists(s) Then
.Cells(2, 2) = d(s)(0)
.Cells(2, 3) = d(s)(1)
.Cells(2, 4) = d(s)(2)
.Cells(2, 5) = d(s)(3)
.Cells(2, 6) = d(s)(4)
.Cells(2, 7) = d(s)(5)
.Cells(2, "o") = d(s)(6)
.Cells(2, "u") = d(s)(7)
End If
End With
Worksheets(fn).Copy
Set wb = ActiveWorkbook
wb.Sheets("登记").DrawingObjects.Delete
wb.SaveAs Filename:=ThisWorkbook.Path & "" & s & "-123.xlsx", FileFormat:=51
wb.Close
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

蜗牛等我 · 发表于 2024-9-19 19:54

ykcbf1100 发表于 2024-9-19 08:17
按表1编号另存

非常感谢，但是我需要一个点击后能够输入的窗口，比如点击合格然后输入合格证编号然后在另存为，因为我有很多合格证，表1也是一样，谢谢，这样能实现吗

ykcbf1100 · 发表于 2024-9-19 20:20

蜗牛等我发表于 2024-9-19 19:54
非常感谢，但是我需要一个点击后能够输入的窗口，比如点击合格然后输入合格证编号然后在另存为，因为我 ...

合格证编号代码已改，另一个代码你自己套改一下吧。

ykcbf1100 · 发表于 2024-9-19 20:21

代码改一下。

Sub ykcbf() '//2024.9.19
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("Scripting.Dictionary")
hgz = Application.InputBox("请输入合格证编号：", "合格证编号", 2024206)
fn = [{"COC","登记"}]
With Sheets("COC")
s = .[l2].Value
d(s) = Array(.[d22].Value, .[d7].Value, .[c7].Value, "2023-1", .[j7].Value, .[f7].Value, .[l5].Value, .[m5].Value, .[k7].Value)
End With
With Sheets("登记")
.Cells(2, "i").Value = hgz
s = hgz
If d.exists(s) Then
.Cells(2, 2) = d(s)(0)
.Cells(2, 3) = d(s)(1)
.Cells(2, 4) = d(s)(2)
.Cells(2, 5) = d(s)(3)
.Cells(2, 6) = d(s)(4)
.Cells(2, 7) = d(s)(5)
.Cells(2, "o") = d(s)(6)
.Cells(2, "p") = d(s)(7)
.Cells(2, "t") = d(s)(8)
End If
End With
Worksheets(fn).Copy
Set wb = ActiveWorkbook
wb.Sheets("登记").DrawingObjects.Delete
wb.SaveAs Filename:=ThisWorkbook.Path & "" & s & "-123.xlsx", FileFormat:=51
wb.Close
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

[求助] 怎么使用VBA一件开合格证

评分

评分

评分