copy & past
22.09.2020 11:26:32
Tom
ich würde Eure Unterstützung benötigen. Die Code holt sich alle Werte aus einer Tabelle, wenn die Zeilen in der Spalte B NICHT leer sind und wenn in der Spalte Y noch kein Datum gesetzt wurde. Nachträgliche Änderungen können erneut abgefragt und unten angehängt werden.
Ich würde folgende Änderung benötigen.
- es soll nicht die komplette Tabelle in meine Auswerttabelle übertragen werden, sondern nur die Spalten A bis L, mit Berücksichtigung der oben beschriebenen Parameter.
-Sobald ich eine Auswertung erstellt habe, speichere ich unter der Angebotsnummer ab. Eine weitere Auswertung mit der selben Datei ist nicht möglich, da der Dateiname umbenannt wurde und mit dem im Code hinterlegten Namen "Auswertung.xlsx" nicht mehr übereinstimmt.
Bei Fragen gerne melden und Danke schon einmal.
Gruß Tom
Hier der Code.
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, 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
strPfadAusw = "\\mndemucfs004\Virtuelle_Auftragsbearbeitung_Bus-Gate\AAP-Stadtbus\ _
04_Bewertung\" 'Verzeichnis mit der Auswertungs-Datei 'anpassen!!
strDateiAusw = "Auswertung.xlsx" 'Name der Auswertungs-Datei - ggf. anpassen!!
'Offene Arbeitsmappe mit Blatt "Protokoll" suchen
For Each wkbP In Application.Workbooks
If fncCheckSheetName(wkbP, "Protokoll") = True Then
Set wksProtokoll = wkbP.Worksheets("Protokoll")
Exit For
End If
Next
If wkbP Is Nothing Then
MsgBox " Die Datei mit dem Blatt ""Protokoll"" ist nicht geöffnet!", vbOKOnly, "Daten in _
_
_
Auswertung übertragen"
Exit Sub
End If
'Prüfen, ob die Auswertungsdatei vorhanden ist
If Dir(strPfadAusw & strDateiAusw) "" Then
'Prüfen, ob Auswertungsdatei göffnet
For Each wkbAusw In Application.Workbooks
If LCase(wkbAusw.Name) = LCase(strDateiAusw) Then Exit For
Next
If wkbAusw Is Nothing Then
'Auswertungsdatei öffnen
Set wkbAusw = Application.Workbooks.Open(strDateiAusw)
End If
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")
Set rngCopy = .Rows(zeiP)
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
Else
MsgBox "Datei " & vbLf & strDateiAusw & vbLf & "nicht gefunden!", _
vbOKOnly, "Daten in Auswertung übertragen"
End If
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