Gerar QRCode no Excel | Mais de Uma Linha | MACRO PRONTA

[@CanalSGP]

MACRO PARA COPIAR:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Erro
Dim Linha As Double, Coluna As Double
Dim ColunaTexto As Double, LinhaCabecalho As Double
Dim ColunaQr As String
ColunaTexto = 1 'Alterar
LinhaCabecalho = 1 'Alterar
ColunaQr = "B" 'Alterar
Linha = Target.Row
Coluna = Target.Column
If Linha > LinhaCabecalho And Coluna = ColunaTexto Then

Application.ScreenUpdating = False
Dim URL As String, TextoQr As String
Dim Imagem As shape
Dim Celula As Range

With ActiveSheet

Set Celula = .Range(ColunaQr & Linha)

For Each Imagem In .Shapes

If Not Intersect(Celula, .Range(Imagem.TopLeftCell.Address, Imagem.BottomRightCell.Address)) Is Nothing Then
On Error Resume Next
.Pictures(Imagem.Name).Delete
Exit For
End If
Next Imagem

Set Celula = Nothing

On Error Resume Next
TextoQr = Target.Text

If TextoQr = Empty Then
.Rows(Linha & ":" & Linha).RowHeight = 15
Application.ScreenUpdating = True
Exit Sub
End If

URL = "api.qrserver.com/v1/create-qr-code/?data=" & TextoQr & "&size=150x150"

.Range(ColunaQr & Linha).Select

.Columns(ColunaQr & ":" & ColunaQr).ColumnWidth = 30
.Rows(Linha & ":" & Linha).RowHeight = 130

.Pictures.Insert(URL).Select

End With

With Selection
.Name = TextoQr
.Top = .TopLeftCell.Top + 10
.Left = .TopLeftCell.Left + 25
End With

On Error Resume Next
Target.Select

Application.ScreenUpdating = True
End If
Exit Sub
Erro:
MsgBox "Erro!", vbCritical, "GERAR QRCODE"
End Sub