VBA Kopieren und als Wert einfügen
02.06.2022 12:07:45
Markus
ich bin noch ein ziemlicher VBA Anfänger und versuche mich mit dem Makro recordingtool voranzubringen.
Ich habe mir hierzu schonmal rat aus dem Forum geholt, und das Archivforum zu diesem Thema ist unter dem folgenden Link: https://www.herber.de/forum/messages/1869289.html
Mir fehlen nun noch die folgenden Schritte bevor die Datei gespeichert wird:
1. In der Registerkarte: Budgetplan 2023 sollen die Spalten L bis N kopiert und an der gleichen Stelle als Werte wieder eingefügt werden, damit die Formeln dahinter verschwinden.
2. In der Registerkarte: Stundensätze 2023 sollen die Spalten B bis P und die Spalten S bis T kopiert und an der gleichen Stelle wieder als Wert eingefügt werden.
3. Da für jeden Kunden eine Datei gespeichert wird, muss die Datei nach dem Speichern in den Ursprungszustand. Die oberen Schritte müssten also wieder Rückgängig gemacht werden.
Ich habe meine Schritte in dem VBA "Code" entsprechend Beschrieben:
----------------------------------------------------
Option Explicit
Sub sbKdListe()
Dim lloRow As Long, lshUE As Worksheet, lshST As Worksheet, lshDB As Worksheet, lshKUSP As Worksheet, lrgCells As Range, lstrPath As String
lstrPath = ThisWorkbook.Path
Set lshUE = Sheets("Budgetplan 2023")
Set lshST = Sheets("Stundensätze 2023")
Set lshDB = Sheets("1. MDS-Daten_gesamt")
Set lshKUSP = Sheets("2. MDS-Daten_SVerweis")
With Sheets("Kundenliste")
'alle Einträge in Spalte A in Tabelle "Kundenliste" werden durchlaufen
For lloRow = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
'erster gefundener Eintrag (danach alle Folgenden) wird in Zelle C3 in Tabelle "Budgetplan 2023" eingetragen
.Range("A" & lloRow).Copy lshUE.Range("C1")
.Range("A" & lloRow).Copy lshST.Range("C1")
'in Tabelle "1. MDS-Daten_gesamt" wird der Autofilter aktiviert und es wird jeweils nach gefundenem Eintrag gefiltert
lshDB.Range("$A$1:$AA$" & lshDB.Cells(lshDB.Rows.Count, 1).End(xlUp).Row).AutoFilter Field:=3, Criteria1:=lshUE.Range("C1")
'wenn in Tabelle "2. MDS-Daten_SVerweis" (alte/vorherige) Dateneinträge vorhanden...
If lshKUSP.Cells(lshKUSP.Rows.Count, 1).End(xlUp).Row >= 3 Then
'...werden diese gelöscht
lshKUSP.Range("A3:AA" & lshKUSP.Cells(lshKUSP.Rows.Count, 1).End(xlUp).Row).Value = ""
End If
'die Tabelle "1. MDS-Daten_gesamt" wird durchlaufen
For Each lrgCells In lshDB.Range("A3:AA" & lshDB.Cells(lshDB.Rows.Count, 1).End(xlUp).Row).Rows
'nur die sichtbaren Zeilen in Tabelle "Datenbank" werden kopiert...
If lrgCells.RowHeight > 0 Then
'...und in Tabelle "2. MDS-Daten_SVerweis" untereinander eingefügt
lshDB.Range("A" & lrgCells.Row & ":AA" & lrgCells.Row).Copy lshKUSP.Range("A" & lshKUSP.Cells(lshKUSP.Rows.Count, 1).End(xlUp).Row + 1)
End If
Next
'nach Einfügen aller gefilterten Datenzeilen wird die Datei als Kopie mit dem Dateinamen "Budgetplanung_KUNDENNAME_Datum.xlsm" gespeichert; anstelle von KUNDENNAME steht der jeweilige Kundenname aus Zelle A1 in Tabelle "Budgetplan 2023"
ThisWorkbook.SaveCopyAs lstrPath & "\Budgetplanung_" & lshUE.Range("C1") & "_" & Date & ".xlsm"
Next
End With
'aufräumen: die Hauptdatei wird wieder in den Ursprungszustand zurückgesetzt
'in Zelle A3 in Tabelle "Busgetplan 2023" steht wieder der Platzhalter "Kundenname"
lshUE.Range("C1").Value = "Kundenname"
lshST.Range("C1").Value = "Kundenname"
'in Tabelle "1. MDS-Daten_gesamt" wird der Autofilter deaktiviert
lshDB.Rows.AutoFilter
'in Tabelle "2. MDS-Daten_SVerweis" werden alle Datenzeilen gelöscht, sodass nur die Überschriftenzeile erhalten bleibt
If lshKUSP.Cells(lshKUSP.Rows.Count, 1).End(xlUp).Row >= 2 Then
lshKUSP.Range("A2:AA" & lshKUSP.Cells(lshKUSP.Rows.Count, 1).End(xlUp).Row).Value = ""
End If
Set lshUE = Nothing
Set lshST = Nothing
Set lshDB = Nothing
Set lshKUSP = Nothing
End Sub
Vielen Dank und viele Grüße,
Markus
P.S.: natürlich hätte ich auch gleich die Datei hochgeladen, aber das funktioniert mit dem Makro leider nicht. Falls es hierfür einen Workaround gibt, gerne Bescheid geben.