Zeilen löschen und einfügen
30.05.2016 08:42:47
Philipp
Ich muss mich wieder an Euch wenden, da ich sowas von komplett auf dem Schlauch stehe.
Ich habe eine Tabelle mit zwei Blättern. Blatt 1 enthält Daten die teilweise nach Blatt 2 kopiert werden sollen. Blatt 2 ist folgendermaßen aufgebaut:
A | B | C | D
Suchbegriff1 | Referenz | Preis | Kommentar
Eintrag | Nummer | Euros | blah
Eintrag | Nummer | Euros | blah
Eintrag | Nummer | Euros | blah
Leerzeile
Suchbegriff2 | Referenz | Preis | Kommentar
Eintrag | Nummer | Euros | blah
Leerzeile
Suchbegriff3 | Referenz | Preis | Kommentar
Eintrag | Nummer | Euros | blah
Eintrag | Nummer | Euros | blah
Eintrag | Nummer | Euros | blah
usw.
Für das Kopieren selektiere ich den Suchbegriff und führe dann das Makro aus. Das Kopieren _ klappt zumindest für den ersten Suchbegriff. Nun habe ich mein Makro dahingehend erweitert, dass es erst prüft, wieviele Einträge überhaupt zu kopieren sind, anschließend den aktuellen Bereich auf Blatt 2 löscht, neue Zeilen einfügt und dann die Daten aus Blatt 1 wieder übernimmt. Mein Problem momentan ist, dass
Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(1, 0).End(xlDown)).EntireRow.Delete
Sub Copy()
Dim a As Long, b As String, c As String, d As Long, i As Long, ix As Integer, Such As String, _
Treffer As Long
c = ActiveCell
a = ActiveCell.Row + 1
b = ActiveCell.Offset(1, 0).Value
d = ActiveCell.Row + 1
With Application
.ScreenUpdating = False
StatusCalc = .Calculation 'Berechnungs-Status merken
.Calculation = xlCalculationManual
.EnableEvents = False
End With
'Zählen wieviele Einträge dem Suchkriterium entsprechen
Such = ActiveCell.Value
Treffer = 0
For i = 13 To 10000
With Worksheets("Blatt1")
If .Cells(i, "I") = c Then
Treffer = Treffer + 1
End If
End With
Next i
'Kopieren
If b = "" Then 'nur kopieren oder zusätzlich löschen/einfügen
For i = 13 To 10000 'Bereiche in Quelle (noch variabel gestalten auf tatsächlichen Bereich)
With Worksheets("Blatt1") ' Quelle
If .Cells(i, "I") = c Then 'Prüfen aus Suchbegriff
Worksheets("Blatt2").Cells(a, 1).Value = Worksheets("Blatt1").Cells(i, 1).Value
Worksheets("Blatt2").Cells(a, 2).Value = Worksheets("Blatt1").Cells(i, 2).Value
Worksheets("Blatt2").Cells(a, 3).Value = Worksheets("Blatt1").Cells(i, 3).Value
Worksheets("Blatt2").Cells(a, 4).Value = Worksheets("Blatt1").Cells(i, 12). _
Value
Worksheets("Blatt2").Cells(a, 5).Value = Worksheets("Blatt1").Cells(i, 10). _
Value
a = a + 1
Else
End If
End With
Next i
Else
Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(1, 0).End(xlDown)).EntireRow.Delete ' _
vorhanden Bereich löschen
For ix = a To Treffer Step 1
ActiveSheet.Cells(ix, 1).EntireRow.Insert ' neue Zeilen einfügen
Next ix
For i = 13 To 10000 'Bereiche in Quelle
With Worksheets("Blatt1")
If .Cells(i, "I") = c Then
Worksheets("Blatt2").Cells(d, 1).Value = Worksheets("Blatt1").Cells(i, 1).Value
Worksheets("Blatt2").Cells(d, 2).Value = Worksheets("Blatt1").Cells(i, 2).Value
Worksheets("Blatt2").Cells(d, 3).Value = Worksheets("Blatt1").Cells(i, 3).Value
Worksheets("Blatt2").Cells(d, 4).Value = Worksheets("Blatt1").Cells(i, 12). _
Value
Worksheets("Blatt2").Cells(d, 5).Value = Worksheets("Blatt1").Cells(i, 10). _
Value
d = d + 1
Else
End If
End With
Next i
End If
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
.EnableEvents = True
End With
End Sub
Das ist sicher verbesserungsfähig (z. B. statt des Aktivierens der einzelnen Suchbegriffe könnte ich versuchen alle Suchbegriffe aus Blatt 1 zu ermitteln und Blatt 2 dementsprechend automatisch strukturieren zu lassen oder ich könnte den Suchbereich dynamisch an den tatsächlichen Bereich anpassen). Aber mein Level ist noch nicht hoch genug ;)
Gruß und Danke im Voraus,
Philipp