ich benötige eure Hilfe, ich komme leider nicht mehr weiter.
Ich habe einen Code erstellt, der mit ein QR-Code erstellt. Ich möchte den Inhalt in Zelle A1 umgewandelt haben in QR-Code und dies in Zelle D1.
Das ganze geht immer weiter A2 in D2 usw. Das ganze läuft, aber sobald es in zweite Zeile geht und den QR-Code erstellen will, kommt diese Fehlermeldung:
"Laufzeitfehler 438; Objekt unterstützt diese Eigenschaft oder Methode nicht".
Wenn ich Debuggen, komme ich in diese Zeile:
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
Kann mir vielleicht jemand sagen, warum? Hin und wieder führt Excel es sauber aus und manchmal nicht.
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("QR Code").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("QR Code") ' 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
Grüße Marco