Copy & Paste
08.10.2020 11:07:14
Tom
ich bekomme einen Fehler und finde den Grund nicht.
Die Tabelleninhalte sollen über den Code unter Berücksichtigung der Parameter in eine eigene Tabelle übernommen werden.
https://www.herber.de/bbs/user/140009.xlsx
Die Prozedur bleibt hier hängen.
Set objListA = wksAusw.ListObjects(1)
Der Code sieht wie folgt aus.
Option Explicit
Sub prcCopy_to_Auswertung()
'übertragung bestimmter Zeilen aus Protokoll in Auswertung
Dim wkbP As Workbook, wksProtokoll As Worksheet
Dim objListP As ListObject, objListA As ListObject
Dim wkbAusw As Workbook, wksAusw As Worksheet
Dim strPfadAusw As String, strDateiAusw As String
Dim i As Integer, strTitel As String
Dim zeiP As Long
Dim rngCopy As Range, rngA As Range
Dim varLfdNr As Variant, varID
Const bolUeberschreiben As Boolean = True 'Wenn False, dann werden beim _
Aktualisieren schon vorhandene Einträge nicht überschrieben
Set wkbP = ActiveWorkbook
Set wksProtokoll = ActiveSheet
'Auswertungsdatei auswählen
With Application.FileDialog(msoFileDialogOpen)
.Title = "Bitte die Auswertungsdatei/letzte Angebotsdatei auswählen!"
.InitialFileName = strPfadAusw & "\"
.AllowMultiSelect = False
If .Show = -1 Then
strDateiAusw = .SelectedItems(1)
Else
Exit Sub
End If
End With
'Auswertungsdatei/Angebotsdatei schreibgeschützt öffnen
Set wkbAusw = Application.Workbooks.Open(strDateiAusw, ReadOnly:=True)
Set wksAusw = wkbAusw.Worksheets(1)
Set objListA = wksAusw.ListObjects(1)
wkbAusw.Activate
Application.ScreenUpdating = False
'Tabellen/ListObjects im Blatt "Protokoll" abarbeiten
For i = 1 To wksProtokoll.ListObjects.Count
Set objListP = wksProtokoll.ListObjects(i)
With objListP
With .DataBodyRange
For zeiP = 1 To .Rows.Count
'Prüfen, ob Spalte B (BV-Version) mit Inhalt und Spalte Y (Datum Antwort) leer
If .Cells(zeiP, 2) "" And .Cells(zeiP, 25) = "" Then
varLfdNr = .Cells(zeiP, 1).Value
varID = "LO" & Format(i, "00") & "|" & Format(varLfdNr, "000")
'zu kopierenden Bereich (APlaten A bis L) setzen
Set rngCopy = .Range(.Cells(zeiP, 1), .Cells(zeiP, 12))
With objListA
If .ListRows.Count = 0 Then 'Listobject hat nur eine Titelzeile und eine _
Datenzeile ohne Daten
.Range.Cells(2, 1) = varID
rngCopy.Copy
.Range.Cells(2, 2).PasteSpecial
.ListRows.Add
Else
With .DataBodyRange
'ID in Spalte A suchen
Set rngA = .Columns(1).Find(varID, LookIn:=xlValues, lookat:=xlWhole)
If rngA Is Nothing Then 'neuer Eintrag
rngCopy.Copy
.Cells(.Rows.Count, 2).PasteSpecial Paste:=xlPasteValues
.Cells(.Rows.Count, 1).Value = varID
objListA.ListRows.Add
Else 'Eintrag schon vorhanden
If bolUeberschreiben = True Then
rngCopy.Copy
rngA.Offset(0, 1).PasteSpecial Paste:=xlPasteValues
End If
End If
End With '.DataBodyRange
End If
End With 'objListA
End If
Next zeiP
End With
End With 'objListP
Next i
Application.CutCopyMode = False
objListA.DataBodyRange.EntireRow.AutoFit
Application.ScreenUpdating = True
End Sub
Public Function fncCheckSheetName(wkb As Workbook, strSheetName As String) As Boolean
Dim objSheet As Object
On Error GoTo Fehler
Set objSheet = wkb.Sheets(strSheetName)
fncCheckSheetName = True
Fehler:
End Function
Danke und viele Grüße
Tom