Anzeige

Komplette Zeile Kopieren und löschen


#1
Hallo,

ich bin noch ziemlich frisch bei VBA und habe mir jetzt ca. eine Stunde Beispiele hier im Forum angeschaut und probiert, komme aber einfach zu keiner Lösung.
Folgenden Vorgang möchte ich abschließen:
In Zelle A1,A2,A3 usw... bis "offenes Ende" (mal bis Zelle K1, mal N2, mal E3 usw...) stehen Daten in einer bestimmten Formatierung mit Hyperlink.
Wenn in I1 nun ein bestimmter Wert steht (4), sollen alle Werte mit Formatierung nach Tabelle2 kopiert und in Tabelle 1 gelöscht werden, so dass die unteren Zeilen nach oben rutschen. In Tabelle 2 stehen Daten, welche nicht durch die neuen Daten überschrieben werden sollen, sondern unter den bereits vorhandenen erscheinen.
Diese Abfrage möchte ich in Tabelle 1 Zeilen für Zeile machen, bis keine Werte mehr da sind.
Weiss jemand wie ich das anfange?
 

Yaslaw

n/a
Moderator
#2
AH - Excel. Gut.

Wenn I1=4 soll verschoben und an Tabelle2 angehängt werden. Dabei wird die Tabelle1 vollständig gelöscht. Also auch die Zeile 1. Das sagt mindestens deine Beschreibung.
Warum Zeile für Zeile. Dein Beschreibung sagt eigentlich: Wenn I1 = 4 dann verschiebe alles. Das kann man ja gleich als Block machen.
 

Yaslaw

n/a
Moderator
#3
Etwa so könnte das aussehen
Visual Basic:
Public Sub doIt()
    Dim wsSrc As Worksheet
    Dim wsTrg As Worksheet
    Dim lastTrgRow As Long
    Dim srcAddress As String
    
    Set wsSrc = ActiveWorkbook.Worksheets("Sheet1")
    Set wsTrg = ActiveWorkbook.Worksheets("Sheet2")
    
    lastTrgRow = xlsGetLastRow(wsTrg)
    
    If wsSrc.Range("I1").Value = 4 Then
        srcAddress = wsSrc.Cells(xlsGetLastRow(wsSrc), xlsGetLastColumn(wsSrc)).Address
        With wsSrc.Range("A1", srcAddress)
            .Copy wsTrg.Cells(lastTrgRow + 1, 1)
            .Delete Shift:=xlUp
        End With
    End If
    
End Sub





'/**
' * Ermittelt die letzte gefüllte Zeile eines Worksheets
' * @param  Worksheet   Das Worksheetobjekt, das durchsucht werden soll
' * @return Long        Die Zeilennummer. Wenn das ganze Sheet leer ist, ist der Rückgabewert 0
' */
Public Function xlsGetLastRow(ByRef sheet As Object) As Long
    Const xlCellTypeLastCell = 11

    'Zur letzten initialisierten Zeile gehen
    xlsGetLastRow = sheet.Cells.SpecialCells(xlCellTypeLastCell).Row
    
    'Von dort zurücksuchen bis zur Letzten zeile mit Inhalt
    Do While sheet.Application.WorksheetFunction.CountA(sheet.rows(xlsGetLastRow)) = 0 And xlsGetLastRow > 1
        xlsGetLastRow = xlsGetLastRow - 1
    Loop
End Function

'/**
' * Ermittelt die letzte gefüllte Zeile eines Worksheets
' * @param  Worksheet   Das Worksheetobjekt, das durchsucht werden soll
' * @return Long        Die Zeilennummer. Wenn das ganze Sheet leer ist, ist der Rückgabewert 0
' */
Public Function xlsGetLastColumn(ByRef sheet As Object) As Long
    Const xlCellTypeLastCell = 11

    'Zur letzten initialisierten Zeile gehen
    xlsGetLastColumn = sheet.Cells.SpecialCells(xlCellTypeLastCell).Column
    
    'Von dort zurücksuchen bis zur Letzten zeile mit Inhalt
    Do While sheet.Application.WorksheetFunction.CountA(sheet.Columns(xlsGetLastColumn)) = 0 And xlsGetLastColumn > 1
        xlsGetLastColumn = xlsGetLastColumn - 1
    Loop
End Function[code]
 
#4
Oh, das habe ich falsch ausgedrückt. Es sollen nur alle Werte mit Formatierung dieser Zeile nach Tabelle 2 verschoben werden, die Zeilen welche <> 4 sind, sollen erhalten bleiben.

Ich habe bisher so angefangen:


Dim RowsMax As Long
Dim lastrow As Long
Dim Row As Long
Dim CE_Project, Finished As Worksheet


With CE_Project
RowsMax = .UsedRange.Rows.Count
lastrow = Finished.Cells(Rows.Count, 9).End(xlUp).Row + 1

Do Until .Cells(Row, 4) = ""
If .Cells(Row, 9) = 4 Then
.Rows(Row).Copy Destination:=Finished.Rows(lastrow)
Row = Row + 1
End If
Loop

Ich weiss allerdings nicht, wie ich die Zeile welche kopiert wurde lösche, so dass der Rest "hochrutscht".
 

Yaslaw

n/a
Moderator
#5
Visual Basic:
.Rows(Row).Copy Destination:=Finished.Rows(lastrow)
.Delete Shift:=xlUp
Row = Row + 1
Aber vorsicht. Das gibt dir ein durcheinander.
  1. Du kopierst Zeile 4
  2. Du löschst Zeile 4
  3. Aus Zeile 5 wird Zeile 4
  4. Du prüfst Zeile 5
Du siehst, da geht eine verloren.
Darum ist es besser das ganz von Unten nach oben abzuarbeiten. Dann ist die Zeile, die nachrutscht bereits gewprüft.

  1. Du kopierst Zeile 4
  2. Du löschst Zeile 4
  3. Aus Zeile 5 wird Zeile 4
  4. Du prüfst Zeile 3

In etwa so
Visual Basic:
row=RowsMax
Do Until Row=1
    If .Cells(Row, 9) = 4 Then
        .Rows(Row).Copy 
        ' Immer an der gleichen Position einfügen und die anderen nach Unten schieben, 
        'damit die Reihenfolge wieder stimmt
        Finished.Rows(lastrow).Insert Shift:=xlDown 
    End If
    Row = Row - 1
Loop{/code]
 
Anzeige

Neue Beiträge

Anzeige