Clever-Excel-Forum

Hallo Zusammen,
nach dem ich viele Foren durchstöbert habe und auch wirkliche Beiträge darüber gibt, war ich trotzdem nicht fähig mir das Richtige zusammen zu basteln. Es ist inwiefern schwierig, da alle zu 95 % dasselbe wollen, jedoch die Programmierbefehle nur zu 20 % ähneln, ist schwierig dort was zu assoziieren. Ich habe es mal versucht und füge euch die Tabelle mit hinzu.

Momentan habe ich das Gefühl, dass ich jeden Tag 200 Excel-Tabellen pflegen muss und ich möchte das gerne ändern, sonst sehe ich bald nur noch Zeilenrahmen. Ich hoffe ihr könnt mir dabei helfen, dadurch würde ich wirklich viel Zeit und Nerven sparen und es auf andere Tabellen anwenden.

Folgendes:
Ich möchte gerne das auf dem Arbeitsblatt "Auftragsplanung" den Inhalt der Zellen A:J (Zelleninhalt beginnt ab Zelle 6) in den Zellen K6:T6 kopiert wird. Jedoch sollte der Zelleninhalt von A:J auch in das Tabellenblatt "Auswertung" A5:J5 mit verschoben werden, also so gesehen einmal Kopieren und einmal Verschieben.
Der Eintrag der kopiert und verschoben werden soll, soll dann natürlich nicht mehr bei "Auftragsplanung" A:J zusehen sein.
Aber das war noch nicht alles. Die nachstehenden Aufträge sollen automatisch nach oben rutschen und die kopierten bzw. verschobene Aufträge sich automatisch nach unten verschieben (K6:T6 bzw. Tabellenblatt "Auswertung").

Der Auslöser des Programms soll der eingestellte Zelleninhalt in J "abgeschlossen" sein.

Ich hoffe ich habe das gut erklärt. Die Datei schicke mit. Ich hoffe das das überhaupt möglich ist. :s

Ein großes großes Danke schön schon mal an denjenigen der sich dieses Problem widmet.

Mit freundlichen Grüßen

TedBraun01

Hallo,

teste mal:

Code:
Private Sub Worksheet_Change(ByVal Target As Range)

  Dim LngZ1 As Long, lngZ2 As Long

  Dim lngZ3 As Long

  With Sheets("Auswertung")

    lngZ3 = .Cells(.Rows.Count, 1).End(xlUp).Row + 1

  End With

  On Error GoTo ende

  Application.EnableEvents = False

  LngZ1 = Cells(Rows.Count, 1).End(xlUp).Row

  lngZ2 = Cells(Rows.Count, 11).End(xlUp).Row + 1

  If Target.Column = 10 And Target.Row > 5 Then

    If Target.Text <> "" Then

      If Target.Text = "abgeschlossen" Then

        Range(Cells(lngZ2, 11), Cells(lngZ2, 20)) = Range(Cells(Target.Row, 1), Cells(Target.Row, 10)).Value

        Sheets("Auswertung").Cells(lngZ3, 1).Resize(, 10) = Range(Cells(Target.Row, 1), Cells(Target.Row, 10)).Value

        If Target.Row < LngZ1 Then

          Range(Cells(Target.Row, 1), Cells(LngZ1 - 1, 10)) = Range(Cells(Target.Row + 1, 1), Cells(LngZ1, 10)).Value

          Range(Cells(LngZ1, 1), Cells(LngZ1, 10)).ClearContents

        Else

          Range(Cells(Target.Row, 1), Cells(Target.Row, 10)).ClearContents

        End If

      End If

    End If

  End If

ende:

  Application.EnableEvents = True

  If Err Then MsgBox "Fehler: " & Err.Number & vbCrLf & vbCrLf & Err.Description

End Sub

Hallo Ted,





' **************************************************************

'  Modul:  Tabelle1  Typ = Element der Mappe(Sheet, Workbook, ...)

' **************************************************************



Option Explicit



Private Sub Worksheet_Change(ByVal Target As Range)

 Dim rngQ As Range

 With Target.Cells(1)

   If .Column = 10 And .Row > 5 Then

     If .Value = "abgeschlossen" Then

       Set rngQ = .Offset(, -9).Resize(, 9)

       rngQ.Copy

       'oben einfügen

       Me.Range("K6").Insert xlDown

       'unten anhängen

       'Me.Range("K" & Rows.Count).End(xlUp).Offset(1).PasteSpecial

       rngQ.Copy

       'oben einfügen

       Tabelle2.Range("A5").Insert xlDown

       'unten anhängen

       'Tabelle2.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial

       rngQ.Resize(, 10).Delete xlUp

     End If

   End If

 End With

End Sub

Gruß Uwe

Hallo,

bei Uwe sehe ich gerade, dass ich das mit nach unten Verschieben übersehen hatte.

Das ist jetzt auch drin:

Code:
Private Sub Worksheet_Change(ByVal Target As Range)

  Dim LngZ As Long

  On Error GoTo ende

  Application.EnableEvents = False

   LngZ = Cells(Rows.Count, 1).End(xlUp).Row

  lngZ2 = Cells(Rows.Count, 11).End(xlUp).Row + 1

  If Target.Column = 10 And Target.Row > 5 Then

    If Target.Text <> "" Then

      If Target.Text = "abgeschlossen" Then

        Range(Cells(6, 11), Cells(6, 20)).Insert xlDown, CopyOrigin:=xlFormatFromRightOrBelow

        Range(Cells(6, 11), Cells(6, 20)) = Range(Cells(Target.Row, 1), Cells(Target.Row, 10)).Value

        Sheets("Auswertung").Cells(5, 1).Resize(, 10).Insert xlDown, CopyOrigin:=xlFormatFromRightOrBelow

        Sheets("Auswertung").Cells(5, 1).Resize(, 10) = Range(Cells(Target.Row, 1), Cells(Target.Row, 10)).Value

        If Target.Row < LngZ Then

          Range(Cells(Target.Row, 1), Cells(LngZ - 1, 10)) = Range(Cells(Target.Row + 1, 1), Cells(LngZ, 10)).Value

          Range(Cells(LngZ, 1), Cells(LngZ, 10)).ClearContents

        Else

          Range(Cells(Target.Row, 1), Cells(Target.Row, 10)).ClearContents

        End If

      End If

    End If

  End If

ende:

  Application.EnableEvents = True

  If Err Then MsgBox "Fehler: " & Err.Number & vbCrLf & vbCrLf & Err.Description

End Sub

Ich lösch' im Bereich Neuaufträge keine Zellen, da sonst die vorgetragenen Formatierungen nach einer Zeit wieder neu eingetragen müssten.

Hallo Uwe und Atilla,

vielen Dank. Beide Programmierung funktionieren einwandfrei. Ein kleine Anmerkung möchte trotzdem zu Uwe noch machen, das ist keine Kritik, weil ich finde ihr beiden habt es voll drauf. Bei Uwes Programmierung geht nach nach dem kopieren in die Zellen K6:T6 meine Formatierung verloren, er zeigt mir dann nur noch die Spalte T grün an, nicht mehr die ganze Zeile von K6:T6.

Atilla? Meinst du du kannst mir nach jeder Zeile eine kleine Erklärung schreiben? Damit ich das vielleicht mal versuchen kann, auf anderen Excel-Tabellen anzuwenden? Das wäre echt klasse. Blush

Wie ich sehe habt ihr beide dasselbe erreicht, aber jedoch auf unterschiedlicher Art und Weise. Gibt es im Internet viellleicht ein Programmieranleitung für VBA? Kennt ihr ne gute Seite, wo man die Programmierung lernen kann?

Ich danke euch nochmal von ganzen Herzen. :28: Ihr habt beide ein dickes Lob verdient.

Vielen Dank nochmal.

Viele Grüße

TedBraun01

Hallo TedBraun,

Zitat:Meinst du du kannst mir nach jeder Zeile eine kleine Erklärung schreiben?

ich habe es mal versucht, merke aber, dass das oft mehr Arbeit ist als den Code zu erstellen.

Gute Seiten zum Lernen sind auf jeden Fall Foren, wie z.B. unseres. Ich habe mein Wissen fast ausschließlich aus Foren.
Auch wenn ich so einen Code erstellen kann, ist mein Wissen und Uwes nicht zu vergleichen. Für mich ist das nur ein Hobby
und somit bin ich nur ein Amateur.

Code:
Private Sub Worksheet_Change(ByVal Target As Range)

 Dim LngZ As Long     'Variablendeklaration vom Typ Long,

 On Error GoTo ende    'wenn ab hier ein Fehler auftaucht, dann geh zur Sprungmarke "ende"

 Application.EnableEvents = False 'Reaktion auf Ereignisse abschalten (würde hier auch ohne funktionieren)

  LngZ = Cells(Rows.Count, 1).End(xlUp).Row   'letzte belegte Zelle in Spalte 1 feststellen und an die Variable lngZ übergeben

 lngZ2 = Cells(Rows.Count, 11).End(xlUp).Row + 1  'diese Zeile ist überflüssig (Überbleibsel vom anderen Code) (mit Option Explicit als erste Codezeile im Modul wäre sie von Excel moniert worden)

 If Target.Column = 10 And Target.Row > 5 Then    'wenn Änderungen in Spalte 10 und Zeilen > 5 stattfinden

   If Target.Text <> "" Then                      'wenn die tangierte Zelle nicht nicht leer ist (könnte auch wegfallen sehe ich gerade)

     If Target.Text = "abgeschlossen" Then        'wenn in der tangierten Zelle "abgeschlossen" steht

       Range(Cells(6, 11), Cells(6, 20)).Insert xlDown, CopyOrigin:=xlFormatFromRightOrBelow  'in den Bereich K6:T6 eine Zellen einfügen mit dem Format der darunter liegenden Zellen

       Range(Cells(6, 11), Cells(6, 20)) = Range(Cells(Target.Row, 1), Cells(Target.Row, 10)).Value 'in den Bereich K6:T6 den Inhalt aus dem Bereich A:J der tangierten Zeile schreiben

       Sheets("Auswertung").Cells(5, 1).Resize(, 10).Insert xlDown, CopyOrigin:=xlFormatFromRightOrBelow  'in Tabelle "Auswertung in den Bereich A5:J5 eine Zellen einfügen mit dem Format der darunter liegenden Zellen

       Sheets("Auswertung").Cells(5, 1).Resize(, 10) = Range(Cells(Target.Row, 1), Cells(Target.Row, 10)).Value 'in Tabelle "Auswertung" in den Bereich A5:J5 den Inhalt aus dem Bereich A:J der tangierten Zeile schreiben

       If Target.Row < LngZ Then    'wenn  Zeilenzahl der tangierten Zelle kleiner als die Zahl ist, die in der Variablen lngZ abgelegt ist dann

         ' den Bereich A:J der tangierten Zeile bis eine Zeile vor der Letzten, überschreiben mit dem Bereich eine Zeile tiefer der tangierten Zeile bis zur letzten Zeile

         Range(Cells(Target.Row, 1), Cells(LngZ - 1, 10)) = Range(Cells(Target.Row + 1, 1), Cells(LngZ, 10)).Value

         Range(Cells(LngZ, 1), Cells(LngZ, 10)).ClearContents 'den Inhalt der letzten Zeile leeren, da doppelt

       Else 'sonst  (die tangierte Zeile ist die letzte Zeile)

         Range(Cells(Target.Row, 1), Cells(Target.Row, 10)).ClearContents 'Inhalt im Bereich A:J der tangierten Zeile löschen

       End If

     End If

   End If

 End If

'ab hier wird der Code immer ausgeführt, während er oben je nach Bedingung verzweigt und nicht ausgeführt werden kann

'Bei Fehlern währen der Codeausführung im obigen Teil wird sofort hierhin gesprungen und der Code hier weitergeführt

ende:

 Application.EnableEvents = True 'deswegen wird hier die Reaktion auf Ereignisse wieder eingeschaltet

 If Err Then MsgBox "Fehler: " & Err.Number & vbCrLf & vbCrLf & Err.Description 'wenn ein Fehler aufgetreten ist, dann Meldung mit Fehlernummer und Beschreibung

End Sub

Hallo Atilla,

Vielen Dank für die Erklärungen, das bringt viel Licht ins Dunkle. Wenn das so erklärt ist wie im dem Fall von dir, dann ist der lernfktor sehr groß. Aber oft stehen nur sehr wenige Erklärungen dabei und das ist sehr schwierig , etwas zu lernen.

Aber so wie du es gemacht hast ist das Einwandfrei.

Vielen Dank nochmal für deine Bemühungen.

Mit freundlich Grüßen

TedBraun01

TedBraun01

atilla

Kuwer

atilla

TedBraun01

atilla

TedBraun01