Clever-Excel-Forum

Normale Version: Häufigkeitsermittlung und Wertkopierung in Tabelle
Du siehst gerade eine vereinfachte Darstellung unserer Inhalte. Normale Ansicht mit richtiger Formatierung.
Seiten: 1 2
Hallo Leon

freut mich das wir die Aufgabe mit Geduld hinbekommen.  Gleichzeitig lernst du etwas über Vba.

Wenn das kopieren lange dauert sollten wir den Kopiervorgang anders schreiben.  s. neues Makro 
Da findest du zwei Befehle die deaktiviert sind, (abgeschaltet) und bei Bedarf durch das Entfernen von ' aktiv werden.  (Programmierer Trick)
Die automatische Berechnung kann per Vba auf Manuell gestellt, und am Ende wieder auf Automatic zurückgestellt werden.

Das ist aber nur erforderlich wenn das kopieren mit dem neuen Code immer noch sehr lange dauert.  Hier siehst du um ersten mal den Code "On Error Goto Fehler", denn wenn jetzt ein Laufzeitfehler auftritt schaltet er die Automatik wieder ein, sonst bliebe sie abgeschaltet!!. Dafür wird der Laufzeit über MsgBox angezeigt.

Das zweite Programm ist zum manuellen löschen von doppelten in Spalte G, indem du die Spalte zuerst manuelle von Hand sortierst, und nach dem löschen nochmal sortierst. Dann bleiben die gewünschten Werte übrig.  Das sortieren bekommen wir auch noch ans laufen.  Bis morgen ...

mfg Gast 123 

Code:
Sub Kopieren_doppelte_löschen()
'Automatisches Berechnen abschalten
'Application.Calculation = xlManual
 
  On Error GoTo Fehler
  Sheets("Tabelle3").Select
  lz = Cells(Rows.Count, 1).End(xlUp).Row

  'Spalte A nach G kopieren, sortieren
  Range("A1:A" & lz).Copy
  Range("G1").PasteSpecial xlValues
  Application.CutCopyMode = False
 
  'Call SpalteG_sortieren   'Sortier Makro
 
  'doppelte löschen, danach sortieren
  For Each AC In Range(Adr1, "G" & lz)
      If AC.Offset(1, 0) = AC.Value Then AC.Value = ""
  Next AC
 
  'Call SpalteG_sortieren   'Sortier Makro
Fehler:  'Berechnen bei Fehler wieder einschalten!!
'Application.Calculation = xlAutomatic
İf Err > 0 Then MsgBox Error()
End Sub


'vorher + nachher Spalte G von Hand sortieren
Sub doppelte_manuell_löschen()
  Sheets("Tabelle3").Select
  lz = Cells(Rows.Count, 1).End(xlUp).Row
  'doppelte löschen, danach sortieren
  For Each AC In Range(Adr1, "G" & lz)
      If AC.Offset(1, 0) = AC.Value Then AC.Value = ""
  Next AC
End Sub
Seiten: 1 2