Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1040to1044
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Zeile ausschneiden und verschieben, wenn "ja"
20.01.2009 09:18:00
Lucia
Hallo zusammen,
ich habe folgendes Makro:
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim intRow As Integer
If Target.Column  16 Then Exit Sub
If IsEmpty(Target) Then Exit Sub
If Target.Value = "Ja" Then
With Worksheets("Rechnungenbezahlt")
intRow = .Cells(Rows.Count, 16).End(xlUp).Row + 1
Rows(Target.Row).Copy .Rows(intRow)
Rows(Target.Row).Delete
End With
End If
Application.CutCopyMode = False
End Sub


Damit werden, wenn ich in einer Zeile im Tabellenblatt "Verbindlichkeiten" auf bezahlt "ja" gehe, die Zeile ausgeschnitten und in ein anderes Tabellenblatt geschoben.
Frage1: wie muss das Makro umformuliert werden, damit diese Aktion erst geschieht, wenn ich auf einen Button "ausbuchen" gehe, ich also gesammelt die Sachen rüber bring und mir das File nicht die ganze Zeit "rattert"
Frage 2: Das File lief in Excel 2003 wunderbar, nur hab ich jetzt in 2007 das Gefühl, dass es "hängt" - was kann ich tun?
Vielen lieben Dank schon mal,
Lucia

20
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Zeile ausschneiden und verschieben, wenn "ja"
20.01.2009 09:46:36
Oberschlumpf
Hi Lucia
Schreib mal diesen Code in das Klick-Ereignis deines Buttons:

If Sheets("DeinSheetName").Range("DieZelleMitJA").Value = "Ja" Then
With Worksheets("Rechnungenbezahlt")
intRow = .Cells(Rows.Count, 16).End(xlUp).Row + 1
Rows(Target.Row).Copy .Rows(intRow)
Rows(Target.Row).Delete
End With
Application.CutCopyMode = False
End If


Alles, was hier im Fettdruck angezeigt wird, musst du anpassen.
Hilfts denn?
Ciao
Thorsten

AW: Zeile ausschneiden und verschieben, wenn "ja"
20.01.2009 10:12:00
Lucia
OK,
Hab das mal so rein gemacht:
Option Explicit

Private Sub CommandButton1_Click()
If Sheets("Verbindlichkeiten").Range("P13:P9999").Value = "Ja" Then
With Worksheets("Rechnungenbezahlt")
intRow = .Cells(Rows.Count, 16).End(xlUp).Row + 1
Rows(Target.Row).Copy .Rows(intRow)
Rows(Target.Row).Delete
End With
Application.CutCopyMode = False
End If
End Sub


Jetzt bitte nicht lachen, aber ich hab das halt so dem Tabellenblatt zu gewiesen, der Button liegt auf dem Tabellenblat, code dahinter, aber wie bekomme ich es jetzt aktiviert? (mein vba ist wirklich bescheiden...sorry)
Grüße, Lucia

Anzeige
AW: Zeile ausschneiden und verschieben, wenn "ja"
20.01.2009 10:18:00
Oberschlumpf
darfst mich auch gern mit Hallo begrüßen ;-)
Hi Lucia
ups...haste da echt fast 10.000 Einträge (Zeilen) drin stehen?
Aber bevor wir hier weiter hin und her korrigieren, hast du vielleicht ine Bsp-Ddatei mit Bsp-Daten, die du uns zur Verfügung stellen kannst?
Es müssen keine fast 10.000 Bsp-Zeilen sein ;-) 10 oder so reichen schon.
Ciao
Thorsten
AW: Zeile ausschneiden und verschieben, wenn "ja"
20.01.2009 10:37:00
Lucia
Hi Thorsten,
Sorry....das war nicht böse und nachlässig gemeint....mir brennt grad der Hintern...aber das is natürlich keine Entschuldigung hier die Grundregeln nicht mehr zu befolgen, daher ein größer *entschuldigungsdrücker" hinterher;-)
unter:
https://www.herber.de/bbs/user/58604.zip
findest du eine Beispieldatei. Ich hoffe, sie hilft. Ja das mit den 10000 Zeilen, naja ganz wird das nicht hinkommen, 1500 werdens aber sicher werden. Über das File managen wir unser ganzen eingehenden Rechnungen (und natürlich noch mehr, was ich aber rausgelöscht hab;-)
Grüße, Lucia
Anzeige
AW: Zeile ausschneiden und verschieben, wenn "ja"
20.01.2009 10:46:00
Oberschlumpf
Hi Lucia
grins...mein Fehler...mit deiner Datei kann ich leider nix anfangen, da ich nicht mit xl2007 sondern mit XL XP arbeite.
Kannst du die datei bitte noch mal im XLS-Format speichern - und was hältst du von Erichs Vorschlag, der ja in seinem Bsp schon die mehreren Zeilen - und sogar mögliche Groß-Kleinschreibung bei "ja/JA/Ja/jA" berücksichtigt hat?
Ciao
Thorsten
AW: Zeile ausschneiden und verschieben, wenn "ja"
20.01.2009 11:21:00
Lucia
Hi Thorsten,
Noch etwas Geduld - er haut mir Datei immer auf 2 MB hoch, wenn ich auf 2003 bringen will....und gezippt sind das auch immernoch zu viel.....bald:-)
AW: Zeile ausschneiden und verschieben, wenn "ja"
20.01.2009 11:23:17
Lucia
Hi,
Was lange wärt wird endlich wahr:
https://www.herber.de/bbs/user/58609.zip
gruß,
Lucia
Anzeige
eine Möglichkeit...
20.01.2009 09:51:34
Tino
Hallo,
steht die letzte Spalte bei dir noch zur Verfügung, kannst Du mal dieses Makro testen.
Weise einem Button dieses Makro zu.
Sub Button_Daten_Uebertragen_Und_Loeschen()
   Dim Bereich As Range
   
   Set Bereich = Range("P2", Cells(Rows.Count, 16).End(xlUp))
   'prüfen ob Bereich in der Überschrift liegt. 
   If Not Intersect(Bereich, Rows(1)) Is Nothing Then Exit Sub
   
   Set Bereich = Bereich.Offset(0, Columns.Count - Bereich.Column)

With Application
 .ScreenUpdating = False
 .EnableEvents = False
  'Formel einfügen 
   Bereich.FormulaR1C1 = "=IF(RC16=""ja"",0,"""")"

On Error GoTo KeineZelle:
   
   Set Bereich = Bereich.SpecialCells(xlCellTypeFormulas, 1)
   
   Bereich.EntireRow.Copy
   
   With Worksheets("Rechnungenbezahlt")
    .Cells(.Rows.Count, 16).End(xlUp).Offset(1, -15).PasteSpecial
    'Formelspalte löschen 
    .Columns(.Columns.Count).Delete
   End With
   'Zeilen löschen 
   Bereich.EntireRow.Delete

KeineZelle:
   'Formelspalte löschen 
   Columns(Columns.Count).Delete
 
 .CutCopyMode = False
 .EnableEvents = True
 .ScreenUpdating = True
End With

End Sub


Gruß Tino

Anzeige
AW: Teste mal mit Deiner Datei...
20.01.2009 11:13:25
Lucia
Hi,
Hui....hier prasselts jetzt aber auf mich ein....Also Code hat beim test mit einer und auch mehreren Zeilen funktioniert, wenn er sich auch sehr schwer getan hat (zeitlich gesehen). Wenn ich nun in die frei gewordene Zeile (Zeile 13) nur eine neue Rechnung eingegeben habe und bezahlt habe, dann wollte er sie nicht mehr haben:-) Was aber gut ist, er schreibt hier alle Zeilen untereinander:-)
Gruß,
LUcia
Anzeige
AW: Teste mal mit Deiner Datei...
20.01.2009 11:43:00
Tino
Hallo,
das kopieren geht sehr schnell, was sehr viel Zeit benötigt ist dass löschen der Zeilen.
Wahrscheinlich durch den Riesen Datenbereich den Du da hast, der geht ja bis in Zeile 1048576.
Schneller bekomme ich es so nicht hin.
Ersetze den Code durch diesen.
Private Sub CommandButton1_Click()
 Dim Bereich As Range
 Dim iCalc As Integer
   Set Bereich = Range("P13", Cells(Rows.Count, 16).End(xlUp))
   'prüfen ob Bereich in der Überschrift liegt. 
   If Not Intersect(Bereich, Rows("1:12")) Is Nothing Then Exit Sub
   
   Set Bereich = Bereich.Offset(0, Columns.Count - Bereich.Column)

With Application
 iCalc = .Calculation
 .Calculation = xlCalculationManual
 .ScreenUpdating = False
 .EnableEvents = False
  'Formel einfügen 
   Bereich.FormulaR1C1 = "=IF(UPPER(RC16)=""JA"",0,"""")"

On Error GoTo KeineZelle:
   Debug.Print Bereich.Address
   Set Bereich = Columns(Columns.Count).SpecialCells(xlCellTypeFormulas, 1)
   Bereich.EntireRow.Copy
     
   With Worksheets("Rechnungenbezahlt")
    .Cells(.Rows.Count, 16).End(xlUp).Offset(1, -15).PasteSpecial
    'Formelspalte löschen 
    .Range(Bereich.Address).Clear
   End With
   'Zeilen löschen 
   Bereich.EntireRow.Delete xlUp

KeineZelle:
   'Formelspalte löschen 
   Columns(Columns.Count).Delete
 
 .CutCopyMode = False
 .EnableEvents = True
 .Calculation = iCalc
 .ScreenUpdating = True
End With
End Sub


Gruß Tino

Anzeige
AW: Teste mal mit Deiner Datei...
20.01.2009 11:51:00
Lucia
Hi Tino,
teste gerade...Excel hat sich nur kurzzeitig von mir verabschiedet, test wird später fortgeführt. Was recht gut klappt ist der Code von Erich (unter deinen threats)...kannst du dir auch mal ankucken for interest. danke dir auf jeden Fall schon mal:-)
Grüße,
Lucia
AW: Teste mal mit Deiner Datei...
20.01.2009 11:56:45
Tino
Hallo,
den habe ich getestet, das löschen der Zeile dauert auch so lang wie in meinem Code.
Wenn die ja Zeilen weit auseinander liegen, dauert er noch länger. ;-)
In meinem war noch ein kleiner Fehler,
die Formelspalte muss in Rechnungenbezahlt auch komplett gelöscht werden.
Option Explicit
Private Sub CommandButton1_Click()
 Dim Bereich As Range
 Dim iCalc As Integer
   Set Bereich = Range("P13", Cells(Rows.Count, 16).End(xlUp))
   'prüfen ob Bereich in der Überschrift liegt. 
   If Not Intersect(Bereich, Rows("1:12")) Is Nothing Then Exit Sub
   
   Set Bereich = Bereich.Offset(0, Columns.Count - Bereich.Column)

With Application
 iCalc = .Calculation
 .Calculation = xlCalculationManual
 .ScreenUpdating = False
 .EnableEvents = False
  'Formel einfügen 
   Bereich.FormulaR1C1 = "=IF(UPPER(RC16)=""JA"",0,"""")"

On Error GoTo KeineZelle:
   Debug.Print Bereich.Address
   Set Bereich = Columns(Columns.Count).SpecialCells(xlCellTypeFormulas, 1)
   Bereich.EntireRow.Copy
     
   With Worksheets("Rechnungenbezahlt")
    .Cells(.Rows.Count, 16).End(xlUp).Offset(1, -15).PasteSpecial
    'Formelspalte löschen 
    .Columns(Columns.Count).Delete
   End With
   'Zeilen löschen 
   Bereich.EntireRow.Delete xlUp

KeineZelle:
   'Formelspalte löschen 
   Columns(Columns.Count).Delete
 
 .CutCopyMode = False
 .EnableEvents = True
 .Calculation = iCalc
 .ScreenUpdating = True
End With
End Sub


Gruß Tino

Anzeige
Sortieren ist das Zauberwort...
20.01.2009 12:41:00
Tino
Hallo,
was Geschwindigkeit bringen könnte, wäre Du Sortierst zuerst Deine Tabelle nach Spalte P.
Schneller bekomme ich nun wirklich nicht hin.
Option Explicit
Private Sub CommandButton1_Click()
 Dim Bereich As Range
 Dim iCalc As Integer
   Set Bereich = Range("P13", Cells(Rows.Count, 16).End(xlUp))
   'prüfen ob Bereich in der Überschrift liegt. 
    
   If Not Intersect(Bereich, Rows("1:12")) Is Nothing Then Exit Sub
   
   Set Bereich = Bereich.Offset(0, Columns.Count - Bereich.Column)

With Application
 iCalc = .Calculation
 .Calculation = xlCalculationManual
 .ScreenUpdating = False
 .EnableEvents = False
 Range("A13", Cells.SpecialCells(xlCellTypeLastCell)).Sort Range("P13"), xlAscending
  'Formel einfügen 
   Bereich.FormulaR1C1 = "=IF(UPPER(RC16)=""JA"",0,"""")"

On Error GoTo KeineZelle:
   Debug.Print Bereich.Address
   Set Bereich = Columns(Columns.Count).SpecialCells(xlCellTypeFormulas, 1)
   Bereich.EntireRow.Copy
     
   With Worksheets("Rechnungenbezahlt")
    .Cells(.Rows.Count, 16).End(xlUp).Offset(1, -15).PasteSpecial
    'Formelspalte löschen 
    .Columns(Columns.Count).Delete
   End With
   'Zeilen löschen 
   Bereich.EntireRow.Delete xlUp

KeineZelle:
   'Formelspalte löschen 
   Columns(Columns.Count).Delete
 
 .CutCopyMode = False
 .EnableEvents = True
 .Calculation = iCalc
 .ScreenUpdating = True
End With
End Sub


Gruß Tino

Anzeige
AW: Sortieren ist das Zauberwort...
20.01.2009 13:48:32
Lucia
Hallo Tino,
Vielen lieben Dank für deine Mühen, es funktioniert auf jeden Fall und ich werd´s mal im Köpfle behalten:-)
Viele Grüße,
LUcia
AW: Zeile ausschneiden und verschieben, wenn "ja"
20.01.2009 10:25:45
Erich
Hallo Lucia,
probiers mal mit

Private Sub CommandButton1_Click()
Dim rngC As Range, rngA As Range
For Each rngC In Range("P2", Cells(Rows.Count, 16).End(xlUp))
If rngC.Row > 1 And rngC.Value = "Ja" Then
If rngA Is Nothing Then Set rngA = rngC Else Set rngA = Union(rngA, rngC)
End If
Next rngC
If Not rngA Is Nothing Then
With Worksheets("Rechnungenbezahlt")            ' Zieltabelle
rngA.EntireRow.Copy .Cells(.Rows.Count, 16).End(xlUp).Offset(1, -15)
rngA.EntireRow.Delete
End With
End If
End Sub

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Anzeige
AW: kleine Ergänzung
20.01.2009 10:29:51
Erich
Hi Lucia,
damit große und kleine ja's keine Probleme bereiten:

Private Sub CommandButton1_Click()
Dim rngC As Range, rngA As Range
For Each rngC In Range("P2", Cells(Rows.Count, 16).End(xlUp))
If rngC.Row > 1 And UCase(rngC.Value) = "JA" Then
If rngA Is Nothing Then Set rngA = rngC Else Set rngA = Union(rngA, rngC)
End If
Next rngC
If Not rngA Is Nothing Then
With Worksheets("Rechnungenbezahlt")            ' Zieltabelle
rngA.EntireRow.Copy .Cells(.Rows.Count, 16).End(xlUp).Offset(1, -15)
rngA.EntireRow.Delete
End With
End If
End Sub

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

AW: kleine Ergänzung
20.01.2009 11:04:32
Lucia
Hi Erich,
Vielen Dank für deine Hilfe. Das Makro funktioniert schon mal:-) Das mit Groß ja und klein ja werd ich noch einbauen, hab zwar dateneingang beschränkt, aber siche rist sicher. Problem, was aufgetaucht ist, ist folgendes: wennn ich in mehreren Etappen "rüberbuche" überschreibt immer die neue Zeile die vorherige. das darf natürlich nicht passieren, toll wäre es, wenn die Zellen untereinander gereiht werden. Zum Beipiel prüfe nach unten wo nächste freie Zeile und schiebe dann rein. Oder So.
danke und liebe Grüße,
LUcia
AW: Rückfrage
20.01.2009 11:29:00
Erich
Hi Lucia,
das kann ich so nicht nachvollziehen - auch nicht beim Test.
Die Zielzelle wird bestimmt mit
.Cells(.Rows.Count, 16).End(xlUp).Offset(1, -15)
Damit wird von Zelle Pnnnnnn aus aufwärts die erste belegte Zelle gesucht,
mit "Offset (1,...)" eine Zeile nach unten und mit "Offset (.., -15)" 15 Spalten nach links (in Spalte A) gegangen.
Ist evtl. in der letzten Zeile deiner Zieltabelle Spalte P leer? (Da sollte Ja drin stehen.)
Dann müsstest du schreiben, wie man die erste freie Zeile erkennen kann.
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
AW: Rückfrage - sorry
20.01.2009 11:39:00
Lucia
Hi Erich,
Test 2....keine Ahnung was bei test 1 los war....test 2 funktioniert, läuft fix und rund. Sorry, irgendwas war da schief gelaufen. Danke dir!
Grüße aus Ulm,
Lucia

310 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige