Hallo liebe Helferlein..............ich wieder mal bräuchte eure Hilfe.

Habe eine Datei wo in der Spalte "A" auf "Tabelle1" ein Wort - -oder zwei oder drei - dann mit Abstand - steht mit dem hier unten ausgewiesenem Code erstellt es mir in der Spalte "D" - also drei Zellen weiter rechts - den jeweiligen QR Code dazu.

Das funktioniert echt super schnell!!! ....der QR Code wird in die besagte Zelle reinkopiert und optimiert.

L e i d e r werden k e i n e Leerzeichen - natürlich nur wenn es zwei oder mehrere Wörter oder Zahlen sind - zwischen den Ausdrücken erstellt??

z.B. in Zelle A1 steht Hallo Code 1 .............dann wirft bzw. lautet der QR Code in Zelle D1 HalloCode1 aus

Hoffe ihr könnt mir helfen !!!
Danke STeve

Hier der Code - welchen ich im Netz gefunden habe:

Sub QR_erstellenx()
Dim objShape As Shape
Dim ws1 As Worksheet
Dim rowRange As Range
Dim count As Integer
Dim x As String

'QRCode_Create Range("D1"), Range("A1")

'Spalte "D" auf größe Einstellen
Columns("D:D").Select
Selection.ColumnWidth = 25.86
Rows("1:100").Select
Selection.RowHeight = 165

'Länge der Liste an Sachnummern zählen
'Set ws1 = ThisWorkbook.Worksheets("QR Code")
'Set rowRange = ws1.Rows("A")
'count = Application.WorksheetFunction.CountA(rowRange)
count = WorksheetFunction.CountA(Sheets("Tabelle1").Range("A:A"))


Dim z As Long

For z = 1 To count
If ActiveSheet.Cells(z, 1) > "" Then
x = ActiveSheet.Cells(z, 1)
x = Replace(x, Space(1), "")
QRCode_Create ActiveSheet.Cells(z, 4), x
QRCode_Edit ActiveSheet.Cells(z, 4)
End If
Next z

'Druckbereich wählen
Print_area

End Sub


Sub QRCode_Create(ZielRange As Range, Text As String)
Dim wdapp As Object
Dim WD As Object
'Abgeleitet aus https://www.ms-office-forum.net/forum/showthread.php?p=2055193

On Error Resume Next

Set wdapp = GetObject(, "Word.Application")
If wdapp Is Nothing Then Set wdapp = CreateObject("Word.Application")
'wdapp.Application.Visible = 1
Set WD = wdapp.Documents.Add
WD.Fields.Add(Range:=WD.Range, Type:=-1, Text:="DISPLAYBARCODE " & Chr(34) & CStr(Text) & Chr(34) & " QR \q 3 \s 100 ", PreserveFormatting:=False).Copy
ZielRange.Select
ZielRange.Parent.PasteSpecial Format:="Picture (JPEG)", Link:=False, DisplayAsIcon:=False

Set wdapp = Nothing
Set WD = Nothing

wdapp.Quit 0


End Sub

Sub QRCode_Edit(ZielRange As Range)
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.ScaleWidth 0.1651126718, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.PictureFormat.Crop.PictureWidth = 454
Selection.ShapeRange.PictureFormat.Crop.PictureHeight = 97
Selection.ShapeRange.PictureFormat.Crop.PictureOffsetX = 189
Selection.ShapeRange.PictureFormat.Crop.PictureOffsetY = 0
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.IncrementTop 7.0587401575
Selection.ShapeRange.ScaleHeight 0.9276018575, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.PictureFormat.Crop.PictureWidth = 454
Selection.ShapeRange.PictureFormat.Crop.PictureHeight = 97
Selection.ShapeRange.PictureFormat.Crop.PictureOffsetX = 189
Selection.ShapeRange.PictureFormat.Crop.PictureOffsetY = -3
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.IncrementLeft 8.8234645669
Selection.ShapeRange.ScaleWidth 0.8823538058, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.PictureFormat.Crop.PictureWidth = 454
Selection.ShapeRange.PictureFormat.Crop.PictureHeight = 97
Selection.ShapeRange.PictureFormat.Crop.PictureOffsetX = 185
Selection.ShapeRange.PictureFormat.Crop.PictureOffsetY = -3
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.IncrementTop 0.00007874015748
Selection.ShapeRange.ScaleHeight 0.7317079966, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.PictureFormat.Crop.PictureWidth = 454
Selection.ShapeRange.PictureFormat.Crop.PictureHeight = 97
Selection.ShapeRange.PictureFormat.Crop.PictureOffsetX = 185
Selection.ShapeRange.PictureFormat.Crop.PictureOffsetY = 8
'Größe ändern
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.ScaleHeight 1.9, msoFalse, msoScaleFromTopLeft
'Zentrieren
For Each objShape In Tabelle1.Shapes
With objShape
If .Type = msoPicture Then
.Left = .TopLeftCell.Left + .TopLeftCell.Width / 2 - .Width / 2
.Top = .TopLeftCell.Top + .TopLeftCell.Height / 2 - .Height / 2
End If
End With
Next
End Sub

Sub ZellenInhaltLoeschenx()
Dim ws As Worksheet
Dim d As Long
Set ws = ThisWorkbook.Worksheets("Tabelle1") ' Ersetze "DeinArbeitsblattName" durch den tatsächlichen Namen deines Arbeitsblatts
'Löschen aller Bilder in Spalte D
For Each shp In ws.Shapes
If Not Intersect(shp.TopLeftCell, Range("D1:D100")) Is Nothing Then shp.Delete
Next shp

'Löschen des gesamten Text
Worksheets("QR Code").Range("A1:D100").ClearContents


End Sub

Sub Print_area()
'Get values
Dim wks As Worksheet
Dim lastCell As Long

For Each wks In ActiveWorkbook.Worksheets
lastCell = wks.Range("A" & Rows.count).End(xlUp).Row
wks.PageSetup.PrintArea = "A1:D" & lastCell
With wks.PageSetup
'.LeftHeader = "Test"
'.CenterHeader = "Test"
.CenterHorizontally = True
.Orientation = xlPortrait
'.PaperSize = xlPaperA2
.FitToPagesWide = 1
End With
Next wks
End Sub