使用VBA Excel生成QR

我使用此代码在excel中生成QR。 但是，如果QR已经存在，则我无法仅在“示例：F2”列中不存在QR的情况下生成它，并跳到下一个单元格。因为每当我单击generate按钮并使其与旧/当前QR重叠时，它都会不断生成。 很高兴有人能帮我。因为我已经被困在这里一个星期了

Option Explicit

Public Sub QRGEN()

Sheet2.Activate
Dim c       As Range

Dim lRow    As Long
lRow = WorksheetFunction.Max(2, Cells(Rows.Count, 1).End(xlUp).Row)
For Each c In Range("F2:F" & lRow)
If c.Offset(0, -1) <> "" Then
    MakeQRCode sData:=c.Offset(0, -1).Text, _
    iForeCol:=vbBlack, iBackCol:=vbWhite, iSize:=60, cell:=c

End If

Next c

End Sub


Function MakeQRCode(sData As String, iForeCol As Long, iBackCol As Long, _
               ByVal iSize, cell As Range) As Boolean
Dim iPic          As Long
Dim sPic          As String
Dim oPic          As Picture
Dim sURL          As String

On Error Resume Next

Do
Set oPic = Nothing
iPic = iPic + 1
sPic = "QRCode(" & iPic & ")"
Set oPic = cell.Worksheet.Pictures(sPic)
Loop While Not oPic Is Nothing
err.Clear

If iSize > 1000 Then iSize = 1000
If iSize < 10 Then iSize = 10

sURL = "https://api.qrserver.com/v1/create-qr-code/?" & _
     "&data=" & sData & _
     "&size=" & iSize & "x" & iSize & _
     "&charset-source=UTF-8" & _
     "&charset-target=UTF-8" & _
     "&ecc=L" & _
     "&color=" & sRGB(iForeCol) & _
     "&bgcolor=" & sRGB(iBackCol) & _
     "&margin=0" & _
     "&qzone=1" & _
     "&format=png"
' Debug.Print sURL

With cell.Worksheet.Pictures.Insert(sURL)
.Name = sPic
.Left = cell.Left + 10.5
.Top = cell.Top + 4
End With

MakeQRCode = err.Number = 0
End Function

Function sRGB(iRGB As Long) As String
' converts an RGB long to RRGGBB
sRGB = Right("00000" & Hex(iRGB), 6)
sRGB = Right(sRGB, 2) & Mid(sRGB, 3, 2) & Left(sRGB, 2)
End Function

选项显式
公共分包商（）
表2.激活
调光范围
暗淡的光线和长的一样
lRow=WorksheetFunction.Max（2，单元格（Rows.Count，1）.End（xlUp）.Row）
对于范围内的每个c（“F2:F”和lRow）
如果c.偏移量（0，-1）”，则
MakeQRCode sData:=c.Offset（0，-1）.Text_
iForeCol:=vbBlack，iBackCol:=vbWhite，iSize:=60，单元格：=c
如果结束
下一个c
端接头
函数MakeQRCode（sData为字符串，iForeCol为长，iBackCol为长_
ByVal iSize，单元格作为范围）作为布尔值
如长
作为字符串的Dim-sPic
黯淡如画
作为字符串的Dim sURL
出错时继续下一步
做
设为零
iPic=iPic+1
sPic=“QRCode（&iPic&”）
设置oPic=单元格.工作表.图片（sPic）
循环而不是什么都不是
呃，明白了
如果iSize>1000，则iSize=1000
如果iSize<10，则iSize=10
苏尔=”https://api.qrserver.com/v1/create-qr-code/?" & _
“&data=“&sData&_
“&size=“&iSize&“x”&iSize&”_
“&charset source=UTF-8”&_
“&charset target=UTF-8”&_
“&ecc=L”&_
“&color=“&sRGB（iForeCol）&_
“&bgcolor=“&sRGB（iBackCol）&_
“&margin=0”&_
“&qzone=1”和_
“&format=png”
'Debug.Print sURL
带单元格。工作表。图片。插入（sURL）
.Name=sPic
.左=单元格。左+10.5
.Top=单元格.Top+4
以
MakeQRCode=err.Number=0
端函数
函数sRGB（iRGB长度）为字符串
'将RGB long转换为RRGGBB
sRGB=右侧（“00000”和十六进制（iRGB），6）
sRGB=右（sRGB，2）和中（sRGB，3，2）和左（sRGB，2）
端函数

最简单但不是最优雅的方法是在

Sub QRGEN（）的顶部添加下一个代码。

过程：

Dim sh As Shape
 For Each sh In ActiveSheet.Shapes
    If InStr(sh.Name, "QRCode") > 0 Then sh.Delete
 Next

这将删除所有QRCode形状并再次处理所有内容，但会失去时间

更好的解决方案是创建一个能够查找QRCode图片并检查其

Top

属性的函数，该函数是

cell.Top+4

中的一个，就像在运行代码中定义的那样。问题是，如果移动图片，代码将不会返回正确的结果。 因此，添加下一个函数：

Function testQRCodeExistence(cell As Range) As Boolean
    Dim sh As Shape
    For Each sh In ActiveSheet.Shapes
        If sh.top = cell.top + 4 Then testQRCodeExistence = True: Exit For
    Next
End Function

If c.Offset(0, -1) <> "" Then
    If Not checkQRPictExistence(c) Then
        MakeQRCode sData:=c.Offset(0, -1).Text, _
          iForeCol:=vbBlack, iBackCol:=vbWhite, iSize:=70, cell:=c
    End If
End If

并在现有代码上添加以下行（易于理解，其中…）：

创建一个新函数，查找QR图片名称中的

单元格。Addres

：

Function checkQRPictExistence(cell As Range) As Boolean
    Dim sh As Shape
    For Each sh In ActiveSheet.Shapes
        If InStr(sh.Name, cell.Address) > 0 Then checkQRPictExistence = True: Exit For
    Next
End Function

并按上述方法插入检查行，但使用最后一个函数：

Function testQRCodeExistence(cell As Range) As Boolean
    Dim sh As Shape
    For Each sh In ActiveSheet.Shapes
        If sh.top = cell.top + 4 Then testQRCodeExistence = True: Exit For
    Next
End Function

If c.Offset(0, -1) <> "" Then
    If Not checkQRPictExistence(c) Then
        MakeQRCode sData:=c.Offset(0, -1).Text, _
          iForeCol:=vbBlack, iBackCol:=vbWhite, iSize:=70, cell:=c
    End If
End If

如果c.Offset（0，-1）”，则
如果不检查是否存在（c），则
MakeQRCode sData:=c.Offset（0，-1）.Text_
iForeCol:=vbBlack，iBackCol:=vbWhite，iSize:=70，单元格：=c
如果结束
如果结束

您试图实现的目标是什么？因为现在你只是要求我们为你（，）做这项工作解决方案是：以上是完全有效的代码。。起初，我尝试在ActiveSheet.Pictures（I）中添加[code]，然后在ActiveSheet.Pictures（I）中添加[code]。如果[\code]，则删除End退出，但它似乎不起作用。请不要在评论中发布代码（无法阅读）。而不是你的问题，并在那里添加/解释。同时检查我发布的链接，请注意“似乎不起作用”不是一个有用的错误描述。使用链接中的信息解决您的问题。我的错。。好的，我再编辑一遍谢谢。非常感谢你的帮助，先生。。以前我已经使用了“sh.delete”一个，但是生成50++需要10-15分钟。。接下来，我将使用上面评论中的解决方案来检查手机中是否有图片，谢谢！到@peh。但是你的要好得多。。再次谢谢你，先生！！非常感谢D@mohd艾扎特：欢迎！但是，为了在（几乎）任何情况下工作，有一些问题需要设置和理解，我认为：默认的形状属性必须是“移动，但不随单元格调整大小”。但是如果您（其他人）插入/删除了一些行怎么办？可以想象一种触发行插入/删除并根据新情况更正图片名称的方法。如果有兴趣，我可以从这个角度想象一些事情。但是，我可以看到，即使您看起来对代码感到满意，您也没有按向上箭头键…亲爱的先生，这将是一个好主意。。谢谢你。。我确实按下了向上箭头，但是，由于我是堆栈溢出中的新手，因此当我单击向上箭头时，它会显示此消息。。“感谢您的反馈！声誉低于15的人所投的票会被记录下来，但不会改变公开显示的帖子分数。”很抱歉，这帮不了什么忙。。但是，顺便说一句，这是有记录的。。我会在这里保持活跃，这样一旦我获得了更多的声誉，我肯定会回到这里D