Hallo liebe Forumsteilnehmer,
hab mal wieder ein Problem und komme nicht weiter.

Bei nachfolgendem Makro kommt an gekennzeichneter Stelle (*****) immer der Laufzeitfehler 1004..Die PasteSpecial-Methode des Range Objektes konnte nicht ausgeführt werden.
Wenn ich noch mal auf Debuggen klick, kommt "Diese Aktion funktioniert nicht bei einer Mehrfachauswahl."

Ich versteh nicht warum
Würde mich freuen, wenn mir hier jemand weiterhelfen könnte.
Besten Dank schon mal.

Gruibe


Sub RE_Bezeichnungen_einlesen_()

Dim lngRow As Long
Dim sPfad As String
Dim kd As String
Dim Formel As String

Dim wb As Workbook: Set wb = Workbooks.Open(Environ("userprofile") & "nextcloudArbeitsschutzVorlagen GBUGBU Excelgbu.xlsm", ReadOnly:=False)
Dim wsDeckblatt As Worksheet


Set wsDeckblatt = Workbooks("gbu.xlsm").Worksheets("0_Deckblatt")
kd = wsDeckblatt.Range("D4").Value


'Dateipfad der Quelldatei
sPfad = Environ$("userprofile") & "NextcloudBetriebe" & kd & "Taetigkeitsnachweisgbu_taetigkeitsnachweis.xlsm"
Set wbQuelle = Workbooks.Open(sPfad)


With ThisWorkbook.Worksheets("Rechnung")
Call .Unprotect

'Zähler
For x = 1 To 8

For lngRow = 20 To 34 Step 2
If IsEmpty(.Cells(lngRow, 2).Value) Then Exit For
Next

If lngRow = 36 Then
Call MsgBox("Keine freie Zeile im Bereich.", vbCritical, "Fehler")
Else

Application.ScreenUpdating = False

With ThisWorkbook.Worksheets("Rechnung")
.Range("B" & lngRow).UnMerge
.Range("N" & lngRow).UnMerge

'Bezeichnung aus TN (setup) übernehmen

If Workbooks("gbu_taetigkeitsnachweis.xlsm").Worksheets(1).Range("L" & x) = "" Then GoTo ganzfertig
Call Workbooks("gbu_taetigkeitsnachweis.xlsm").Worksheets(1).Range("L" & x).Copy
Call ThisWorkbook.Worksheets("Rechnung").Range("B" & lngRow).PasteSpecial(Paste:=xlPasteValues)
ThisWorkbook.Worksheets("Rechnung").Range("s" & lngRow).FormulaR1C1 = "=RC[-5]*RC[-2]"
.Range("B" & lngRow & ":L" & lngRow).Merge

'Anzahl Stunden aus TN (setup) übernehmen

If Workbooks("gbu_taetigkeitsnachweis.xlsm").Worksheets(1).Range("M" & x) > 0 Then
Call Workbooks("gbu_taetigkeitsnachweis.xlsm").Worksheets(1).Range("M" & x).Copy
Call ThisWorkbook.Worksheets("Rechnung").Range("Q" & lngRow).PasteSpecial(Paste:=xlPasteValues)
ThisWorkbook.Worksheets("Rechnung").Range("M" & lngRow).Value = "Std."
Call Workbooks("gbu_taetigkeitsnachweis.xlsm").Worksheets(2).Range("H32").Copy
Call ThisWorkbook.Worksheets("Rechnung").Range("N" & lngRow).PasteSpecial(Paste:=xlPasteValues)
.Range("B" & lngRow & ":L" & lngRow).Merge

End If
GoTo km


'Kilometer aus TN (setup) übernehmen
km:

If Workbooks("gbu_taetigkeitsnachweis.xlsm").Worksheets(1).Range("N" & x) > 0 Then
Call Workbooks("gbu_taetigkeitsnachweis.xlsm").Worksheets(1).Range("N" & x).Copy
Call ThisWorkbook.Worksheets("Rechnung").Range("Q" & lngRow).PasteSpecial(Paste:=xlPasteValues)
ThisWorkbook.Worksheets("Rechnung").Range("M" & lngRow).Value = "Km"
Call Workbooks("gbu_taetigkeitsnachweis.xlsm").Worksheets(2).Range("H33").Copy
****** Call ThisWorkbook.Worksheets("Rechnung").Range("N" & lngRow).PasteSpecial(Paste:=xlPasteValues)
.Range("B" & lngRow & ":L" & lngRow).Merge


End If

GoTo pauschale


'Pauschale aus TN (setup) übernehmen
pauschale:


If Workbooks("gbu_taetigkeitsnachweis.xlsm").Worksheets(1).Range("O" & x) > 0 Then
Call Workbooks("gbu_taetigkeitsnachweis.xlsm").Worksheets(1).Range("O" & x).Copy
Call ThisWorkbook.Worksheets("Rechnung").Range("Q" & lngRow).PasteSpecial(Paste:=xlPasteValues)
ThisWorkbook.Worksheets("Rechnung").Range("M" & lngRow).Value = "Pauschale"
Call Workbooks("gbu_taetigkeitsnachweis.xlsm").Worksheets(2).Range("H34").Copy
Call ThisWorkbook.Worksheets("Rechnung").Range("N" & lngRow).PasteSpecial(Paste:=xlPasteValues)
.Range("B" & lngRow & ":L" & lngRow).Merge
End If

End With

Workbooks("gbu_rechnung.xlsm").Activate
Sheets("Rechnung").Range("N20:N" & Cells(Rows.Count, 14).End(xlUp).Row).Select

With Selection
.NumberFormat = "#,##0 €"
.Font.ColorIndex = 13
End With

.Range("N" & lngRow & ":O" & lngRow).Merge

Application.ScreenUpdating = True

End If


Next x

ganzfertig:
.Range("B" & lngRow & ":L" & lngRow).Merge
.Range("N" & lngRow & ":O" & lngRow).Merge


End With

With ThisWorkbook.Worksheets("Rechnung")
Call .Protect
End With

'Inhalte aus TN Bereich Spalte L-O löschen

DisplayAlerts = False
Workbooks.Open (sPfad)
Sheets("setup").Activate
Range("L1:O20").ClearContents
ActiveWorkbook.Close SaveChanges:=True

End Sub