Excel: Makro zur Erstellung einer Liste

  • #1
S

saletco

Mitglied
Themenersteller
Dabei seit
02.04.2005
Beiträge
11
Reaktionspunkte
0
HAllo zusammen,

bin absolut neu im Umgang mit Excel Makroprogrammierung und lese jetzt seit Stunden und bin von Minute zu Minute verwirrter.

Ich möchte eigentlich nur eine Liste aus einer Tabelle erstellen. Und zwar:

Tabelle Ergebnisliste

Spalten:
Nummer, Name, Ort


Hier sollen nur dann die Zeilenwerte Nummer, Name und Ort aus der Quelle eingefügt werden, wenn in der Spalte NUMMER (Quelle) 3 Zeichen lang ist und überhaupt ein Wert vorhanden ist.

Wenn nicht, dann soll die Zeile der Quelle ignoriert werden.


Tabelle Quelldaten:

Nummer, Name, Ort

z.B.
123 Meier Hamburg
324 Huber Köln
Hugo Berlin
342 Möller Frankfurt




BITTE BITTE helft mir - ich nehme an, dass das eine einfache Übung ist , aber ich blicks nicht.

Gruß
Kai
 
  • #2
Hallo Saletco,

wie gewünscht. Wenn Du noch Fragen dazu hast, melde dich.

Gruß Matjes :)

Code: 
Sub ErgebnislisteErzeugen()
 ->Erzeugt ein neues Blatt Ergebnisliste
 ->Überträgt auf das neue Blatt die Spalten
 ->Nummer,Name, Ort
 ->wenn in Spalte Nummer eine dreistellige Zahl steht
  
 ->Konstanten
  Const c_NameErg = Ergebnisliste
  Const c_SollLng = 3
  
  Const c_ersteWerteZeile = 2->ggf. anpassen !!!!
  Const c_SPNr = 1   'A
  Const c_SPName = 2->B
  Const c_SPOrt = 3 ->C
  
  
  Dim ws_akt As Worksheet, ws_erg As Worksheet
  Dim l_ZeileZiel As Long, x As Long, l_ZeileMax As Long
  
 ->aktuelles Blatt
  Set ws_akt = ActiveSheet
  
 ->Prüfen, ob Ergebnisblatt schon
  On Error Resume Next
  Set ws_erg = Worksheets(c_NameErg)
  If Err.Number = 0 Then
    MsgBox (Es existiert bereits ein Blatt mitdem Namen  & c_NameErg & _
            vbLf & vbLf & Bitte umbenennen oder löschen.)
    Exit Sub
  Else
    Err.Clear
    
  End If
  On Error GoTo 0
  
 ->Ergebnisblatt neu anlegen
  Worksheets.Add After:=ws_akt
  Set ws_erg = ActiveSheet
  ws_erg.Name = c_NameErg
  
 ->Überschriften auf Ergebnisliste
  l_ZeileZiel = 1
  ws_erg.Cells(l_ZeileZiel, c_SPNr).Value = Nummer
  ws_erg.Cells(l_ZeileZiel, c_SPName).Value = Name
  ws_erg.Cells(l_ZeileZiel, c_SPOrt).Value = Ort
  
 ->Zeile max auf Quellblatt
  l_ZeileMax = ws_akt.Cells(ws_akt.Rows.Count, c_SPNr).End(xlUp).Row
  
 ->Zeilen auf Quelleblatt untersuchen
  For x = c_ersteWerteZeile To l_ZeileMax
   ->Nummer 3 Zeichen ?
    If c_SollLng = Len(ws_akt.Cells(x, c_SPNr).Value) Then
     ->nächste frei Zeile Ziel
      l_ZeileZiel = l_ZeileZiel + 1
     ->Wert übertragen
      ws_erg.Cells(l_ZeileZiel, c_SPNr).Value = ws_akt.Cells(x, c_SPNr).Value
      ws_erg.Cells(l_ZeileZiel, c_SPName).Value = ws_akt.Cells(x, c_SPName).Value
      ws_erg.Cells(l_ZeileZiel, c_SPOrt).Value = ws_akt.Cells(x, c_SPOrt).Value
    End If
  Next
  
 ->Aufraeumen
  Set ws_akt = Nothing: Set ws_erg = Nothing
End Sub
 
  • #3
HAllo Matjes,

vielen Dank - toll... bin absolut begeistert.

Eine erste Frage habe ich : wenn die Nummern länger als 3 Stellen sind, z.b. 11stellig, dann wäre es gut, wenn das Format der Spalte noch mit definiert werden könnte, da ich ansonsten Ausgaben bekomme wie 1.2345E+10 etc.

Was müsste ich noch wo einfügen, bitte?

... achso: wenn ich excel starte und mein excel-file aufrufe, soll excel automatisch das Makro ausführen. Leider kommt nur die Abfrage, ob Makros aktivieren oder deaktivieren. Klicke ich auf aktivieren, passiert nichts. ich muss dann noch extra das Makro aufrufen. Wo kann ich das einstellen, dass das Makro automatisch ausgeführt wird beim Öffnen des Files?

Vielen Dank und Grüße
Kai
 
  • #4
Hi saletco,

a) um das beim Öffnen zu automatisieren muß dem Makro auch der Name des Quellblattes bekannt sein. Wie lautet der ?

b) soll alles als Text formatiert werden ?

c) Soll eine vorhandene Ergebnis-Liste automatisch gelöscht und dann neu angelegt oder soll die neu Ergebnisliste mit Datum/Uhrzeit hinzugefügt werden ?

Gruß Matjes :)
 
  • #5
Hallo Matjes,

Morgenstund hat Gold im Mund :)

a) das Quellblatt heißt Rohdaten

b) da ich mit den Daten nicht rechne, kann gerne alles als Text formatiert werden

c) Ja, das ist ein guter Punkt. Ich möchte die Ergebnisliste als Basis zur weiteren Verarbeitung nutzen. In einem dritten Tabellenblatt möchte ich eine gelayoutete Seite kreieren. Ich habe eben festgestellt, dass mit jedem Mal, wenn eine neue Ergebnisliste erstellt wird, im dritten Blatt der Bezug weg ist.

Im Grunde müsste lediglich der Inhalt der Ergebnisliste einfach gelöscht werden (dann ist der Bezug noch da, oder?) und die Daten neu reingeschrieben werden.

Gruß
Kai
 
  • #6
Hallo saletco,

dann also eine neue Version - du siehst ganz so einfach ist das nicht  ;D

Diese Prozedur muß in eine Modul stehen:
1) Excel-Datei öffnen
2) VB-Ediotr öffnen Alt+F11
Links siehst Du ein Fenster mit der Überschrift Projekt-VBA-Project.
In diesem Fenster ist die Arbeitsmappe unter dem Namen VBAProject(Dateiname) zu finden.
3) VBAProject(Dateiname) selektieren
3) rechte Maustaste->Modul->Modul einfuegen
in der Mitte geht das Code-Fenster Dateiname - Modulx(Code) auf
4) den folgenden Code per copy und Paste in dieses Fenster hineinkopieren
Code: 
Sub ErgebnislisteErzeugen2()
 ->Erzeugt ein neues Blatt Ergebnisliste
 ->ggf. vorhanden Ergebnisliste wird gelöscht
 ->Überträgt auf das neue Blatt die Spalten
 ->Nummer,Name, Ort
 ->wenn in Spalte Nummer eine dreistellige Zahl steht
 ->die Werte wrden als Text formatiert
  
 ->Konstanten
  Const c_NameErg = Ergebnisliste
  Const c_NameQuelle = Rohdaten
  Const c_SollLng = 3
  
  Const c_ersteWerteZeile = 2->ggf. anpassen
  Const c_SPNr = 1   'A
  Const c_SPName = 2->B
  Const c_SPOrt = 3 ->C
  
  
  Dim ws_quelle As Worksheet, l_QuelleZeileMax As Long, x As Long
  Dim ws_erg As Worksheet, l_ZielZeileMax As Long, l_ZielZeile As Long
  
 ->Prüfen, Quellblatt vorhanen
  On Error Resume Next
  Set ws_quelle = Worksheets(c_NameQuelle)
  If Err.Number <> 0 Then
    Err.Clear
    MsgBox (Quell-Blatt  & c_NameQuelle &  nicht vorhanden :-()
    Exit Sub
  End If
  On Error GoTo 0
 ->Zeile max auf Quellblatt
  l_QuelleZeileMax = ws_quelle.Cells(ws_quelle.Rows.Count, c_SPNr).End(xlUp).Row
  
 ->Prüfen, ob Ergebnisblatt schon
  On Error Resume Next
  Set ws_erg = Worksheets(c_NameErg)
  If Err.Number = 0 Then
   ->Ergebnisblatt schon vorhanden
    l_ZielZeileMax = ws_erg.Cells(ws_erg.Rows.Count, c_SPNr).End(xlUp).Row
   ->Zellinhalte löschen
    For x = c_ersteWerteZeile To l_ZielZeileMax
      ws_erg.Cells(x, c_SPNr).Value = 
      ws_erg.Cells(x, c_SPName).Value = 
      ws_erg.Cells(x, c_SPOrt).Value = 
    Next
  Else
    Err.Clear
   ->Ergebnisblatt neu anlegen
    Worksheets.Add After:=ws_quelle
    Set ws_erg = ActiveSheet
    ws_erg.Name = c_NameErg
   ->Überschriften auf Ergebnisliste
    ws_erg.Cells(1, c_SPNr).Value = Nummer
    ws_erg.Cells(1, c_SPName).Value = Name
    ws_erg.Cells(1, c_SPOrt).Value = Ort
  End If
  On Error GoTo 0
  
 ->Spalten als Text formatieren
  ws_erg.Range(ws_erg.Cells(1, c_SPNr), _
               ws_erg.Cells(l_QuelleZeileMax, c_SPNr)).NumberFormat = @
  ws_erg.Range(ws_erg.Cells(1, c_SPName), _
               ws_erg.Cells(l_QuelleZeileMax, c_SPName)).NumberFormat = @
  ws_erg.Range(ws_erg.Cells(1, c_SPOrt), _
               ws_erg.Cells(l_QuelleZeileMax, c_SPOrt)).NumberFormat = @
  
 ->Zeilen auf Quelleblatt untersuchen
  For x = c_ersteWerteZeile To l_QuelleZeileMax
   ->Nummer 3 Zeichen ?
    If c_SollLng = Len(ws_quelle.Cells(x, c_SPNr).Value) Then
     ->nächste frei Zeile Ziel
      l_ZielZeile = l_ZielZeile + 1
     ->Wert übertragen
      ws_erg.Cells(l_ZielZeile, c_SPNr).Value = ws_quelle.Cells(x, c_SPNr).Value
      ws_erg.Cells(l_ZielZeile, c_SPName).Value = ws_quelle.Cells(x, c_SPName).Value
      ws_erg.Cells(l_ZielZeile, c_SPOrt).Value = ws_quelle.Cells(x, c_SPOrt).Value
    End If
  Next
  
 ->Aufraeumen
  Set ws_quelle = Nothing: Set ws_erg = Nothing
End Sub
5) speichern mit Alt+S

Damit das Ganze auch beim Öffnen der Datei ausgeführt wird:
1) DieseArbeitsmappe im VBAProject-Fenster doppelklicken
in der Mitte geht das Code-Fenster Dateiname - DieseArbeitsmappe (Code) auf
2) den folgenden Code per copy und Paste in dieses Fenster hineinkopieren
Code: 
Private Sub Workbook_Open()
  Call ErgebnislisteErzeugen2
End Sub
3) speichern mit Alt+S
4) VB-Editor schliessen mit Alt+Q

Ausprobieren ...

Gruß Matjes :)
 
  • #7
Cool ... funktioniert soweit.

Allerdings wird bei mir bei der Nummer immernoch das 1.2344E+ angezeigt. Markiere ich die Zelle, ist der Inhalt oben richtig.

Vielleicht wäre es doch besser, das ZAhlenformat mit 0 Dezimalstellen zu verwenden. Was muss ich als Format-Bezeichner eintragen?

Gibt es auch eine Möglichkeit, dass zuerst die Rohdaten erneut importiert werden BEVOR das Makro automatisch ausgeführt wird?

Derzeit habe ich beim Import das eingestellt gehabt, dass die Rohdaten beim Öffnen des Files geladen werden. Die Makros scheinen aber Vorrang zu haben.

Zwischendrin nochmal: vielen Dank für deine Hilfe

Gruß
Kai
 
  • #8
Hi saletco,

der Makro hat noch ein Bug - rasiert die Überschriftenzeile auf dem Ergebnisblatt weg - ist jetzt korrigiert.

Nummernformat ist jetzt Zahl ohne Nachkommastellen fur Spalte Nummer.

Mit einem Trick von Klexy werden die Zellen jetzt nochmal durch sich selbst ersetzt, so daß es jetzt unbedingt mit dem Format klappen müßte.

Bzgl. der Aktuallisierung der Rohdaten hab ich in den Open-Makro statt der direkten Ausführung  ein zeitverzögertes Ausführen des Makros eingebaut.

Gruß Matjes :)

Code: 
Private Sub Workbook_Open()
  Application.OnTime Now + TimeValue(00:00:15), ErgebnislisteErzeugen2
End Sub
Code: 
Option Explicit
Sub ErgebnislisteErzeugen2()
 ->Erzeugt ein neues Blatt Ergebnisliste
 ->ggf. vorhanden Ergebnisliste wird gelöscht
 ->Überträgt auf das neue Blatt die Spalten
 ->Nummer,Name, Ort
 ->wenn in Spalte Nummer eine dreistellige Zahl steht
 ->die Werte wrden als Text formatiert
  
 ->Konstanten
  Const c_NameErg = Ergebnisliste
  Const c_NameQuelle = Rohdaten
  Const c_SollLng = 3
  
  Const c_ersteWerteZeile = 2->ggf. anpassen
  Const c_SPNr = 1   'A
  Const c_SPName = 2->B
  Const c_SPOrt = 3 ->C
  
  
  Dim ws_quelle As Worksheet, l_QuelleZeileMax As Long, x As Long
  Dim ws_erg As Worksheet, l_ZielZeileMax As Long, l_ZielZeile As Long
  
 ->Prüfen, Quellblatt vorhanen
  On Error Resume Next
  Set ws_quelle = Worksheets(c_NameQuelle)
  If Err.Number <> 0 Then
    Err.Clear
    MsgBox (Quell-Blatt  & c_NameQuelle &  nicht vorhanden :-()
    Exit Sub
  End If
  On Error GoTo 0
 ->Zeile max auf Quellblatt
  l_QuelleZeileMax = ws_quelle.Cells(ws_quelle.Rows.Count, c_SPNr).End(xlUp).Row
  
 ->Prüfen, ob Ergebnisblatt schon
  On Error Resume Next
  Set ws_erg = Worksheets(c_NameErg)
  If Err.Number = 0 Then
   ->Ergebnisblatt schon vorhanden
    l_ZielZeileMax = ws_erg.Cells(ws_erg.Rows.Count, c_SPNr).End(xlUp).Row
   ->Zellinhalte löschen
    For x = c_ersteWerteZeile To l_ZielZeileMax
      ws_erg.Cells(x, c_SPNr).Value = 
      ws_erg.Cells(x, c_SPName).Value = 
      ws_erg.Cells(x, c_SPOrt).Value = 
    Next
  Else
    Err.Clear
   ->Ergebnisblatt neu anlegen
    Worksheets.Add After:=ws_quelle
    Set ws_erg = ActiveSheet
    ws_erg.Name = c_NameErg
   ->Überschriften auf Ergebnisliste
    ws_erg.Cells(1, c_SPNr).Value = Nummer
    ws_erg.Cells(1, c_SPName).Value = Name
    ws_erg.Cells(1, c_SPOrt).Value = Ort
  End If
  On Error GoTo 0
  
 ->Spalten als Text formatieren
  ws_erg.Range(ws_erg.Cells(1, c_SPNr), _
               ws_erg.Cells(l_QuelleZeileMax, c_SPNr)).NumberFormat = 0
  ws_erg.Range(ws_erg.Cells(1, c_SPName), _
               ws_erg.Cells(l_QuelleZeileMax, c_SPName)).NumberFormat = @
  ws_erg.Range(ws_erg.Cells(1, c_SPOrt), _
               ws_erg.Cells(l_QuelleZeileMax, c_SPOrt)).NumberFormat = @
  
 ->nächste frei Zeile auf Zielblatt
  l_ZielZeile = c_ersteWerteZeile
  
 ->Zeilen auf Quelleblatt untersuchen
  ws_erg.Activate
  For x = c_ersteWerteZeile To l_QuelleZeileMax
   ->Nummer 3 Zeichen ?
    If c_SollLng = Len(ws_quelle.Cells(x, c_SPNr).Value) Then
     ->Wert übertragen
      ws_erg.Cells(l_ZielZeile, c_SPNr).Value = ws_quelle.Cells(x, c_SPNr).Value
      ws_erg.Cells(l_ZielZeile, c_SPNr).Select
     ->klexys Trick :-)
      Selection.Replace What:=Selection.Value, Replacement:=Selection.Value
      ws_erg.Cells(l_ZielZeile, c_SPName).Value = ws_quelle.Cells(x, c_SPName).Value
      ws_erg.Cells(l_ZielZeile, c_SPName).Select
      Selection.Replace What:=Selection.Value, Replacement:=Selection.Value
      ws_erg.Cells(l_ZielZeile, c_SPOrt).Value = ws_quelle.Cells(x, c_SPOrt).Value
      ws_erg.Cells(l_ZielZeile, c_SPOrt).Select
      Selection.Replace What:=Selection.Value, Replacement:=Selection.Value
     ->nächste frei Zeile Ziel
      l_ZielZeile = l_ZielZeile + 1
    End If
  Next
  
 ->Aufraeumen
  Set ws_quelle = Nothing: Set ws_erg = Nothing
End Sub
 
  • #9
Danke,

bei mir gibt es eine Debugg-Meldung bzgl des Select:

Code: 
ws_erg.Cells(l_ZielZeile, c_SPNr).Select

Der Import wird trotzdem erst danach ausgeführt.

Ist aber nicht so schlimm, Hauptsache ist, dass die Werte verschoben werden und das so funktioniert, wie es dies ja dank deiner Hilfe tut.

Vielen Dank
Gruß
Kai
 
  • #10
Hi saletco,

hab die Version oben ein wenig geändert.

Der Open-Makro ruft den eigentlichen mit der OnTime-Funktion auf - jetzt mit einer Verzögerung von 15 Sekunden. Wenn das nicht ausreicht, bzw. zu lang ist, kannst Du es dort korrigieren.

Korrektur bzgl. der Debug-Meldung ist auch drin.

Gruß Matjes  :)
 
Thema:

Excel: Makro zur Erstellung einer Liste

ANGEBOTE & SPONSOREN

Neueste Themen

Statistik des Forums

Themen
113.840
Beiträge
707.966
Mitglieder
51.494
Neuestes Mitglied
Flensburg45
Oben