Office: VBA Code für Zellenkopierung

Hi ich habe eine Frage habe eine Exel Liste.
Tabelle G501 / Tabelle Spezial.

Folgendes soll nun passieren.

aus der Tabelle G501 soll eine bestimmte Zeile von bis in die Tabelle Spezial kopiert werden, unter der Vorraussetzung in der Tabelle G501 steht unter zb. G2 ein X. Wie kann ich das in einem Code ausdrucken?

IN Tabelle G501 ist bereits ein Code für eine Bedingte Formatiierung vorhanden der soll auch bestehen bleiben.

Vielen Dank.

 

Hi ,

schreibe deinen Code für Spalte G wie folgt:

Code:

      Case 7 '=G
        r.Interior.ColorIndex = 6
        With Worksheets("Spezial")
            If .FilterMode Then .ShowAllData
            Range(Cells(r.Row, 1), Cells(r.Row, 4)).Copy
            .Cells(IIf(IsEmpty(.Cells(.Rows.Count, 5)), .Cells(.Rows.Count, 5).End(xlUp).Row, .Rows.Count) + 1, 5).PasteSpecial Paste:=xlValues
        End With
        Application.CutCopyMode = False

Bis später,
Karin

 

Hi Karin,

danke für die schnelle antwort. das ganze klappt auch nur ich hab jetzt folgendes Problem.

wenn ich den Ocde da unten einfüge. Dann ist es egal wo ich das x eingebe? ob bei G oder H oder I. Es wird immer die zeile kopiert?

 

Hi,

wenn du ihn nur in die Case-Anweisung für Spalte 7 (G) schreibst (so wie im Beispiel), dann wird er nur ausgelöst wenn in Spalte G ein "x" oder "X" eingetragen wird - in den anderen Spalten wird er nicht ausgelöst.

Bis später,
Karin

 

HI:) danke. das hat super geklappt. Super Danke.

vielleicht noch eins, dann ist das Thema geschlossen.

Kannst du mir noch erklären wie ich es auch rückgängig machen kann? das heisst wenn ich das X wieder lösche, soll auch in der Tabelle Spezial das gerade eben kopierte wieder gelöscht werden:)

Wäre super.

 

Hi,

soll wirklich immer nur der gerade getätigte Eintrag gelöscht werden, oder betrifft das einen beliebigen Eintrag bei dem ein bereits vorhandenes "x" gelöscht wird? Wenn letzteres der Fall ist - ist die Vertragsnummer ein eindeutiger Begriff oder kann er auch mehrmals vorkommen? Woran erkennt man dann, dass gerade dieser Eintrag gelöscht werden soll (man benötigt ein eindeutiges Suchkriterium um dies zu realisieren)?

Bis später,
Karin

 

HI. es sollte ein beliebigen Eintrage bei dem ein bereits vorhandenes "x" gelöscht wird.

Wenn ich so recht überlege ist es doch ein wenig kompliziert.

Die Tabelle sieht wie folgt aus.
TABELLE SPEZIAL
A B C D A B C
1
2
3

in der Tabelle sind kundendaten. Nun möchte ich dadurch das ich in der Tabelle D ein "x" eintrage soll die zeile A1 - C1 von Tabelle in Spezial kopiert werden. Das heisst aber auch wenn ich das X wieder lösche soll der gleiche Eintrag gelöscht werden. Beispiel. ich gebe bei D2 ein "X" ein, dieser wird in Spezial gelöscht, danach gebe ich in D3 auch ein "X" ein, auch dieser wird kopiert. Wenn ich aber das "x" aus D2 lösche, soll auch diese Zeile Also von A2 - C2 aus dem Tabellen Blatt Spezial gelöscht werden? ist das überhaupt möglich?

Falls nicht auch nicht schlimm, mit deinem Code vorher hast du mir schon sehr weit geholfen.

 

Hi,

ja, das ist möglich, aber nur dann, wenn es eben ein Kriterium gibt, welches ein-eindeutig ist - also nur 1 einziges Mal vorkommt. Wenn in Spalte A dieses ein-eindeutige Kriterium (wie in deinem Beispiel die fortlaufenden Zahlen von 1 an) steht, dann lässt sich das mit folgendemr Code realisieren:

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r As Range
    Dim raZelle As Range
    On Error GoTo fertig
    If Not Intersect(Target, Range("g2:N1000")) Is Nothing Then
      Set r = Range(Cells(Target.Row, 1), Cells(Target.Row, 14))
      If LCase(Target) = "x" Then
        Select Case Target.Column
          Case 7 '=G
          r.Interior.ColorIndex = 6
            With Worksheets("Spezial")
                If .FilterMode Then .ShowAllData
                Set raZelle = .Columns(5).Find(r.Cells(1), lookat:=xlWhole)
                If Not raZelle Is Nothing Then
                    MsgBox "Diesen Eintrag gibt es bereits"
                Else
                    Range(Cells(r.Row, 1), Cells(r.Row, 4)).Copy
                    .Cells(IIf(IsEmpty(.Cells(.Rows.Count, 5)), .Cells( _
                        .Rows.Count, 5).End(xlUp).Row, .Rows.Count) + 1, 5).PasteSpecial _
                        Paste:=xlValues
                End If
            End With
            Application.CutCopyMode = False
        Case 8 '=H
            r.Interior.ColorIndex = 38
          Case 9 '=I
            r.Interior.ColorIndex = 12
          Case 10 '=J
            r.Interior.ColorIndex = 28
          Case 11 '=K
            r.Interior.ColorIndex = 40
          Case 12 '=L
            r.Interior.ColorIndex = 3
          Case 13 '=M
            r.Interior.ColorIndex = 15
          Case 14 '=N
            r.Interior.ColorIndex = 32
        End Select
      ElseIf Target = "" Then
        r.Interior.ColorIndex = xlNone
        With Worksheets("Spezial")
            Set raZelle = .Columns(5).Find(r.Cells(1), lookat:=xlWhole)
            If Not raZelle Is Nothing Then
                .Range(.Cells(raZelle.Row, 5), .Cells(raZelle.Row, 8)).ClearContents
                .Rows(raZelle.Row).Delete Shift:=(xlUp)
            End If
        End With
      End If
    End If
    Set raZelle = Nothing
fertig:
End Sub

Der Code ist geschrieben unter der Annahme, dass das "x" - so wie in deinem ersten Beitrag erwähnt - in Spalte G (nicht D!) eingetragen (bzw. wieder gelöscht) wird, außerdem werden die Spalten A:D nach "Spezial" kopiert (und nicht A:C!)

Bis später,
Karin

 

Das ist super:) das klappt auch wunderbar.

Bzgl. der Annahme, dass das "x" in G nicht in D steht, ist kein Problem ich kann es mir ja so umschreiben, ein wenig hab ich ja schon gelernt.

Es klappt. Vor allem das mit der MSG Box eine Super Idee. wenn jetzt der Eintrag doppelt ist, kommt die Meldung " diesen Eintrag gibt es bereits "

Besten Dank Karin.

 

Hi wie gehts. Je länger ich an der Tabelle arbeite desto mehr fragen und Probleme tauchen auf, vielleicht kann mir wieder jemand helfen.

Folgende Formel habe ich in meiner Tabelle alles klappt wunderbar.

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r As Range
    Dim raZelle As Range
    On Error GoTo fertig
    If Not Intersect(Target, Range("g2:U1000")) Is Nothing Then
      Set r = Range(Cells(Target.Row, 1), Cells(Target.Row, 21))
      If LCase(Target) = "x" Then
        Select Case Target.Column
          Case 7 '=G
          r.Interior.ColorIndex = 6
          Case 21 '=Spezial
            With Worksheets("Spezial")
                If .FilterMode Then .ShowAllData
                Set raZelle = .Columns(4).Find(r.Cells(1), lookat:=xlWhole)
                If Not raZelle Is Nothing Then
                    MsgBox "Diesen Eintrag gibt es bereits in der Spezialrecherche"
                Else
                    Range(Cells(r.Row, 1), Cells(r.Row, 4)).Copy
                    .Cells(IIf(IsEmpty(.Cells(.Rows.Count, 4)), .Cells( _
                        .Rows.Count, 4).End(xlUp).Row, .Rows.Count) + 1,4).PasteSpecial _
              Paste:=xlValues
                End If
            End With
            Application.CutCopyMode = False
          Case 8 '=H
            r.Interior.ColorIndex = 38
          Case 9 '=I
            r.Interior.ColorIndex = 12
          Case 10 '=J
            r.Interior.ColorIndex = 28
          Case 11 '=K
            r.Interior.ColorIndex = 40
          Case 12 '=L
            r.Interior.ColorIndex = 3
          Case 13 '=M
            r.Interior.ColorIndex = 15
          Case 14 '=N
            r.Interior.ColorIndex = 32
        End Select
      ElseIf Target = "" Then
        r.Interior.ColorIndex = xlNone
        With Worksheets("Spezial")
            Set raZelle = .Columns(4).Find(r.Cells(1), lookat:=xlWhole)
            If Not raZelle Is Nothing Then
                .Range(.Cells(raZelle.Row, 4), .Cells(raZelle.Row, 7)).ClearContents
                .Rows(raZelle.Row).Delete Shift:=(xlUp)
            End If
        End With
      End If
    End If
    Set raZelle = Nothing
fertig:
End Sub

Der Code ist super und ist super Toll.
In der Liste gibt es eine Formel die sagt " wenn ich in Case 21 ein X eingebe, kopiere Zeile 1-4 und fürge diese in die Tabelle Spezial ein ab Zeile 4, sollte es bereits eine kopie geben, gib mir die MSGbox" Sollte das x rausgenommen werden, lösche alles wieder.

So nun zu meinem Problem, ich möchte genau diese Anweisung für ein weiteres Case haben und zwar für Case 17, alle bedinungen sollen gleich bleiben.

Klar jetzt könnte man sagen hm, kopier doch die eine Formel und änder nur die Daten ab? ich blicke bei VBA einfach nicht durch ich weiss nicht wo anfang und ende ist geschweige den wo ich die neue Formel einfügen kann und wo ich diese beenden kann.

kann mir vielleicht nochmal jemand helfen? Also noch mal Kurz. Zur Kopierfunktion soll einfach eine weitere Kopierfunktion zugefügt werden. Die Änderbaren Daten " Tabellenname " Case " zu kopierende Zeile " kann ich selber ändern, mir müsste nur jemand sagen wo die Formel hin kommt? und welche Formel in dem o.g. Code genau für das Kopieren zuständig ist?

 

Hi,

ändere einfach in deinem Code diese Zeile:

Code:

          Case 21 

in diese

Code:

          Case 17, 21 

Bis später,
Karin

PS: Deine Ausführungen zum Code stimmen nicht ganz: nicht Zeile 1-4 wird kopiert, sondern Spalte 1-4 in der Zeile, in der in Spalte 21 ein "x" eingetragen wird. Außerdem - Code ist keine Formel sondern eben Code.

 

hi danke für die Info. sorry hab mich etwas falsch ausgedrückt.

Ich weiss ist sicher nicht gut jedes mal was nachzu schiessen.

Nochmal zu meinem problem. wenn ich den gleichen COde für Case 17 haben möchte, da hast du geschrieben einfach

Ich möchte das ganze ja auch verstehen, wie würde es aussehen wenn ich sagen möchte, Case 17 soll aber in einer ganz anderen Tabelle kopiert werden. Mein problem ist einfach ich weiss nicht wo ich die zusätzliche Formel hinkopieren müsste um zusätzlich eine kopierfunktion einzufügen die ich dann selbstständig einfach ändern kann.

zb. Wenn das x in case 17 steht kopiere nach Tabelle xy
Wenn das x in Case 21 steht kopiere nach Tabelle yz.

Code:

Case 21 '=Spezial
            With Worksheets("Spezial")
                If .FilterMode Then .ShowAllData
                Set raZelle = .Columns(4).Find(r.Cells(1), lookat:=xlWhole)
                If Not raZelle Is Nothing Then
                    MsgBox "Diesen Eintrag gibt es bereits in der 

Code:

ElseIf Target = "" Then
        r.Interior.ColorIndex = xlNone
        With Worksheets("Spezial")
            Set raZelle = .Columns(4).Find(r.Cells(1), lookat:=xlWhole)
            If Not raZelle Is Nothing Then
                .Range(.Cells(raZelle.Row, 4), .Cells(raZelle.Row, 7)).ClearContents
                .Rows(raZelle.Row).Delete Shift:=(xlUp)
            End If 

sind das die codes für die kopierbefehle? wo ist der Anfang und wo das ende?

Kann mir jemand noch ein gutes Buch / PDF vorschlagen wie ich VBA lernen könnte?

 

Hi,

eine Select Case Anweisung ist eine Verzweigung des Codes, der in Abhängigkeit davon wonach verzweigt werden soll (also was z.B. in der Zeile: Case 21 steht) unterschiedliche Ausführungen möglich macht. Wenn hinter Case durch Komma getrennte Angaben stehen, wird bei Erfüllung sowohl der einen als auch der anderen Bedingung das ausgeführt, was innerhalb des betreffenden Case-Teils steht.

Will man jedoch Unterschiedliches ausführen, dann ist dafür immer ein getrennter Case-Teil notwendig - so wie das in deinem Code bereits mit Case 8, Case 9 usw. steht. Willst du folglich für Spalte 17 in ein anderes Tabellenblatt kopieren, musst du in einem neuen Case-Teil den selben Code wie für Case 21 verwenden, nur dass es dann nicht With Worksheets("Sezial") heißt, sondern z.B. With Worksheets("AndereTabelle").

Ich habe den Code aus Case 21 mal mit einigen Kommentaren versehen, die machen das Ganze ein wenig verständlicher:

Code:

            ' alles in Tabelle "Spezial" ausführen
            With Worksheets("Spezial")
                ' Autofilter zurücksetzen falls etwas ausgewählt ist
                If .FilterMode Then .ShowAllData
                ' suche in Spalte 4 den Inhalt der Zelle r, vergleiche mit dem gesamten Zellinhalt
                Set raZelle = .Columns(4).Find(r.Cells(1), lookat:=xlWhole)
                ' der Inhalt von r wurde gefunden
                If Not raZelle Is Nothing Then
                    MsgBox "Diesen Eintrag gibt es bereits in der Spezialrecherche"
                ' der Inhalt von r wurde nicht gefunden
                Else
                    ' kopiere Spalte A:D der Zeile von r
                    Range(Cells(r.Row, 1), Cells(r.Row, 4)).Copy
                    ' in die erste freie Zeile in Spalte D einfügen, nur die Werte
                    .Cells(IIf(IsEmpty(.Cells(.Rows.Count, 4)), .Cells( _
                        .Rows.Count, 4).End(xlUp).Row, .Rows.Count) + 1, 4).PasteSpecial _
              Paste:=xlValues
                End If
            End With
            ' Zwischenablage leeren
            Application.CutCopyMode = False

Als Lektüre könnte ich folgendes vorschlagen:

ftp://ftp.fernuni-hagen.de/pub/pdf/urz-broschueren/broschueren/b0049807.pdf

Schau dir vielleicht auch mal diese hilfreichen Seiten an:

http://excelwelt.de/
http://excelabc.de/

Bis später,
Karin

 

Supi danke das hab ich jetzt auch soweit verstanden, hab es auch schon in meiner liste eingefügt und siehe da es klappt.

nun zu dem Code wenn das x rausgenommen wird. kannst du mir den nochmal erklären und vielleicht auch sagen wo ich den einsetzen würde? weil wenn ich den einsetze sagt das system immer Fehler beim Komplieren Else ohne IF

bei mir sieht das ganze nämlich so aus.

Code:

 Case 14 '=N
            r.Interior.ColorIndex = 32
        End Select
ElseIf Target = "" Then
        r.Interior.ColorIndex = xlNone
        With Worksheets("Spezial")
            Set raZelle = .Columns(4).Find(r.Cells(1), lookat:=xlWhole)
            If Not raZelle Is Nothing Then
                .Range(.Cells(raZelle.Row, 4), .Cells(raZelle.Row, 7)).ClearContents
                .Rows(raZelle.Row).Delete Shift:=(xlUp)
                End If 
            ElseIf Target = "" Then
        r.Interior.ColorIndex = xlNone
        With Worksheets("LA Liste")
            Set raZelle = .Columns(1).Find(r.Cells(1), lookat:=xlWhole)
            If Not raZelle Is Nothing Then
                .Range(.Cells(raZelle.Row, 1), .Cells(raZelle.Row, 4)).ClearContents
                .Rows(raZelle.Row).Delete Shift:=(xlUp)
            End If
        End With
      End If
    End If
    Set raZelle = Nothing
fertig:
End Sub

Wofür steht das End IF und das End With?

 

Hi Thor,

so sollte der Code ohne Fehlermeldung laufen:

Code:

    ' Inhalt wurde gelöscht
    ElseIf Target = "" Then
        ' Füllfarbe der Zeile zurücksetzen in der das "x" gelöscht wurde
        r.Interior.ColorIndex = xlNone
        ' "x" wurde in Spalte 21 gelöscht
        If Target.Column = 21 Then
            ' Code in Tabvelle "Spezial" ausführen
            With Worksheets("Spezial")
                ' suche in Spalte D nach dem Wert aus Spalte A, gesamten Zellinhalt vergleichen
                Set raZelle = .Columns(4).Find(r.Cells(1), lookat:=xlWhole)
                ' Eintrag wurde gefunden dann gefundene Zeile löschen
                If Not raZelle Is Nothing Then .Rows(raZelle.Row).Delete Shift:=(xlUp)
            End With
        ' "x" wurde in Spalte 17 gelöscht
        ElseIf Target.Column = 17 Then
            ' Code in Tabelle "LA Liste" ausführen
            With Worksheets("LA Liste")
                ' suche in Spalte A nach dem Wert aus Spalte A, gesamten Zellinhalt vergleichen
                Set raZelle = .Columns(1).Find(r.Cells(1), lookat:=xlWhole)
                ' Eintrag wurde gefunden dann gefundene Zeile löschen
                If Not raZelle Is Nothing Then .Rows(raZelle.Row).Delete Shift:=(xlUp)
            End With
        End If
    End If
    Set raZelle = Nothing

Ich habe den Code noch etwas vereinfacht - wenn die Zeile sowieso gelöscht wird, muss der Inhalt vorher nicht noch gelöscht werden.

Tipp: wenn du mit Einrückungen im Code arbeitest, dann versuche, die zusammengehörigen Befehlsanfängszeile und Befehlsendezeile immer auf eine gemeinsame Position (von Links gesehen) zu bringen, dann siehst du auch, wo noch eine Befehlszeile fehlt.

Eine Select Case Anweisung ist folgendermaßen aufgebaut:

Code:

    Select Case Bedingung
        ' Bedingung 1 erfüllt
        Case Bedingung1
            ' dann dieser Code
        ' Bedingung 2 erfüllt
        Case Bedingung2
            ' dann dieser Code
        ' Bedingung 3 erfüllt
        Case Bedingung3
            ' dann dieser Code
        ' in jedem andere Fall
        Case Else
            ' dann dieser Code
    End Select

Case Else und einzelne Case können natürlich weggelassen werden, wenn nicht erforderlich. Die Anzahl an Case kann beliebig sein.

Eine If Anweisung beseteht aus folgenden Teilen:

Code:

    ' Bedingung 1 ist erfüllt
    If A = 1 Then
        ' dann dieser Code
    ' Bedingung 2 ist erfüllt
    ElseIf A = 2 Then
        ' dann dieser Code
    ' Bedingung 3 ist erfüllt
    ElseIf A = 3 Then
        ' dann dieser Code
    ' jegliche andere als 1, 2 und 3 ist erfüllt
    Else
        ' dann dieser Code
    End If

Sowohl ElseIf als auch Else können natürlich weggelassen werden wenn nicht erforderlich.

Eine With Anweisung bezieht sich immer auf ein bestimmtes Objekt. Dabei ist wichtig, dass innerhalb der With-Anweisung der Bezug auf dieses Objekt mit einem . (Punkt) gekennzeichnet ist.

Code:

    ' Befehle mit . beziehen sich auf Tabelle "Spezial"
    With Worksheets("Spezial")
        ' Zelle A1 der Tabelle "Spezial" erhält den Wert 20
        .Range("A1") = 10
    End With

Bis später,
Karin