Excel Formel oder Makro

Dieses Thema Excel Formel oder Makro im Forum "Microsoft Office Suite" wurde erstellt von routsch, 25. Aug. 2008.

Thema: Excel Formel oder Makro Hallo Ich habe folgendes Problem. Ich habe eine grosse Liste bei welcher sämtliche zeilen welche im feld C1 und D1...

  1. Hallo
    Ich habe folgendes Problem. Ich habe eine grosse Liste bei welcher sämtliche zeilen welche im feld C1 und D1 den richtigen Eintrag haben (Schweiz & 1), in eine zweite Tabelle kopiertwerden.
    Bsp:
    [table]
    [tr]
    [td]A1[/td]
    [td]B1[/td]
    [td]C1[/td]
    [td]D1[/td]
    [/tr]
    [tr]
    [td]Hans[/td]
    [td]Muster[/td]
    [td]Schweiz[/td]
    [td]1[/td]
    [/tr]

    [/table]

    Ich kenne Verweis aber Makros überhaubt nicht...
    Kann mir jemand helfen damit ich in dem zweiten Tabellenblatt sämtliche Zeilen mit den Vorgaben bekomme?
    Am besten eine anleitung für dummies ;-)
    Vielen Dank
     
  2. Hallo routsch,

    möchtest du es denn mal mit einem Makro probieren ?

    Wenn ja, müßtest du einige Angabe machen:
    Quelle:
    - Dateiname
    - Blattname des Blattes auf dem Schweiz in Spalte C und 1 in Spalte D gesucht werden sollen.
    - in welcher Zeile/n steht die Überschrift (oder in welcher Zeile steht der erste Datensatz)
    - Gibt es Zellen mit Text, der größer als 256 Zeichen ist ?
    -Welche Spalte ist immer ausgefüllt ? Spalte A ? (zur Bestimmung des letzten Datensatzes)

    Ziel:
    - Dateiname
    - Blattname

    -Lage der Zieldatei zur Quelldatei ( wäre gut, wenn die im Verzeichnis der Quelldatei läge)

    Gruß Matjes :)
     
  3. hallo

    sehr gerne würde ich es mit einem makro probieren. bin mich auch am einlesen und versuche es mit makroaufzeichnung. da fehlt mir aber zum beispiel der befehl einfügen in der nächsten leeren zeile :-\

    Zu deinen Fragen:
    Vorhandene Liste: Adressen.xls
    Blattname: Adressen (Schweiz steht in H2 -> und nicht Schweiz sondern CH ;-) die Nummer 1 steht in Spalte L.
    Es gibt nur eine Zeile als Überschrift somit ist der erste Datensatz in Zeile 2.
    Das Makro sollte so funktionieren, dass es dann auch nach DE (auch Spalte H) suchen soll und auch 1 in Spalte L.
    die gefundenen zeilen soll es dann am schluss der ersten liste schweiz anhängen. (mit einer zeile als überschrift Deutschland)
    Spalte N ist immer ausgefüllt. Es gibt kein Feld das grösser als 256 zeichen ist.
    Ziel Dokumen: Adressen_sortiert.xls
    Blattname: Adressen_d_1

    Beide Dateien sind im selben verzeichnis...

    vielen dank für deine Hilfe.
    Gruss
    Routsch
     
  4. Hallo routsch,

    ich hab dir den folgend Makro zusammengestellt. Probier ihn aus und laß hören, was noch verbessert / geändert werden muß.

    Code:
    Option Explicit
    
     Private Const c_KENNUNGLAND_CH = CH
     Private Const c_KENNUNGLAND_D = DE
     Private Const c_KENNUNG_EINS = 1
     
     Private Const cQ_DATEINAME = Adressen.xls    ->Dateiname der zu sortierenden Datei (Quelle)
     Private Const cQ_BLTNAME = Adressen       ->Blattname (Quelle)
     Private Const cQ_ZUEBERSCHR = 1          ->Überschriften-Zeile
     Private Const cQ_ZERSTEW = 2            ->erste Wertezeile
     Private Const cQ_SP_LAND = 8            ->Spalte H mit Länderkennung
     Private Const cQ_SP_EINS = 12           ->Spalte L mit Kennung 1
     Private Const cQ_SP_N = 14             ->Spalte, die immer gefüllt ist - zur Bestimmung der letzten Zeile
     
     Private Const cZ_DATEINAME = Adressen_sortiert.xls->Dateiname der zu sortierenden Datei  (Ziel)
     Private Const cZ_BLTNAME_TEIL_1 = Adressen_   ->Vorlage Blattname, Länderkennung wird eingefügt
     Private Const cZ_BLTNAME_TEIL_2 = _1
     Private Const cBLTNAME_TMP = ___TEMP___     ->temporäres Blatt in der Zieldatei
    
    '**********************************************************************************************
    Sub AdrCHundDsortiert()
    
     Dim wbq As Workbook, wsq As Worksheet, wbz As Workbook, wsz As Worksheet
     
     If Not QuelldateiUndBlattBestimmen(cQ_DATEINAME, wbq, cQ_BLTNAME, wsq) Then GoTo AUFRAEUMEN
     If Not ZieldateiVorbereiten(wbq.Path, cZ_DATEINAME, wbz, cBLTNAME_TMP) Then GoTo AUFRAEUMEN
     
    ->Quellblatt als CH-Blatt und DE-Blatt in Zieldatei kopieren
     wsq.Copy After:=wbz.Worksheets(1)
     wbz.Worksheets(2).Name = c_KENNUNGLAND_D
     wsq.Copy After:=wbz.Worksheets(1)
     wbz.Worksheets(2).Name = c_KENNUNGLAND_CH
     
    ->Temporäres Blatt in Zieldatei löschen
     Application.DisplayAlerts = False
     wbz.Worksheets(cBLTNAME_TMP).Delete
     Application.DisplayAlerts = True
     
    ->Für alle Blätter in der Zieldatei
     For Each wsz In wbz.Worksheets
     ->alle Sätze außer der Länderkennung / 1 auf dem Blatt löschen
      Call NurLaenderkennungMitEinsStehenLassen(wsz)->Ländrkennung = Blattname
     ->Endgueltiger Blattname z.B. Adresse_DE_1
      wsz.Name = cZ_BLTNAME_TEIL_1 & wsz.Name & cZ_BLTNAME_TEIL_2
     Next
      
    AUFRAEUMEN:
     Set wbq = Nothing: Set wsq = Nothing
    End Sub
    '**********************************************************************************************
    Private Function NurLaenderkennungMitEinsStehenLassen(ws As Worksheet)
     
     Dim r As Range
     Dim sLaenderkennung As String
     Dim lRows As Long
     Dim Suchbegriff As Variant
    
     sLaenderkennung = ws.Name->Blattname ist Länderkennung
     
    ->letzte Zeile bestimmen
     lRows = ws.Cells(ws.Rows.Count, cQ_SP_N).End(xlUp).Row
    ->keine Zeilen vorhanden -> Ende der Bearbeitung
     If lRows < cQ_ZERSTEW Then GoTo AUFRAEUMEN->wenn
     
    ->Wenn mehr als eine Zeile vorhanden ist sortieren Länderkennung und 1
     If lRows > cQ_ZERSTEW Then
      ws.Rows(cQ_ZERSTEW & : & lRows).Sort _
       Key1:=ws.Cells(cQ_ZERSTEW, cQ_SP_LAND), Order1:=xlAscending, _
       Key2:=ws.Cells(cQ_ZERSTEW, cQ_SP_EINS), Order2:=xlAscending, _
       Header:=xlNo
     End If
     
     Suchbegriff = sLaenderkennung
     Call AlleZeilenOhneSuchbegriffLoeschen(ws, Suchbegriff, cQ_SP_LAND, cQ_ZERSTEW, cQ_SP_N)
     Suchbegriff = 1
     Call AlleZeilenOhneSuchbegriffLoeschen(ws, Suchbegriff, cQ_SP_EINS, cQ_ZERSTEW, cQ_SP_N)
      
    AUFRAEUMEN:
     Set r = Nothing
    End Function
    '**********************************************************************************************
    Private Function QuelldateiUndBlattBestimmen(sDateiname As String, _
                           wb As Workbook, _
                           sBlattname As String, _
                           ws As Worksheet) As Boolean
    ->Quelldatei muß geöffnet sein, sonst -> Fehler
     On Error Resume Next
     Set wb = Nothing
     Set wb = Workbooks(sDateiname)
     On Error GoTo 0
     If wb Is Nothing Then
      MsgBox Quelldatei  & sDateiname &  ist nicht geöffnet.
      GoTo AUFRAEUMEN
     End If
     
    ->Quellblatt setzen
     On Error Resume Next
     Set ws = Nothing
     Set ws = wb.Worksheets(sBlattname)
     On Error GoTo 0
     If ws Is Nothing Then
      MsgBox In Quelldatei  & wb.Name &  ist das Blatt  & sBlattname &  nicht vorhanden.
      GoTo AUFRAEUMEN
     End If
     
     QuelldateiUndBlattBestimmen = True->Rückgabekennung OK
     
    AUFRAEUMEN:
    
    End Function
    '**********************************************************************************************
    Private Function ZieldateiVorbereiten(sPfad As String, _
                       sDateiname As String, _
                       wb As Workbook, _
                       sBlattname_tmp As String) As Boolean
     Dim x As Long
     
    ->Zieldatedatei existiert ?
     If Dir(sPfad & Application.PathSeparator & sDateiname, vbNormal) =  Then
     ->Datei nicht vorhanden -> neu anlegen
      Set wb = Workbooks.Add
      Application.DisplayAlerts = False
      For x = wb.Worksheets.Count To 2 Step -1
       wb.Worksheets(x).Delete
      Next
      Application.DisplayAlerts = True
     ->einziges Blatt wird temporäres blatt
      wb.Worksheets(1).Name = sBlattname_tmp
      wb.SaveAs Filename:=sPfad & Application.PathSeparator & sDateiname
     Else
     ->Datei vorhanden
      
     ->offen ?
      On Error Resume Next
      Set wb = Nothing
      Set wb = Workbooks(sDateiname)
      On Error GoTo 0
      If wb Is Nothing Then
      ->noch nicht offen -> öffnen
       On Error Resume Next
       Set wb = Workbooks.Open(sPfad & Application.PathSeparator & sDateiname)
       On Error GoTo 0
       If wb Is Nothing Then
        MsgBox Zieldatei  & sPfad & Application.PathSeparator & sDateiname &  kann nicht geöffnet werden.
        GoTo AUFRAEUMEN
       End If
      End If
     ->alle Blätter bis auf das letzte löschen
      Application.DisplayAlerts = False
      For x = wb.Worksheets.Count To 2 Step -1
       wb.Worksheets(x).Delete
      Next
      Application.DisplayAlerts = True
     ->einziges Blatt wird temporäres blatt
      wb.Worksheets(1).Name = sBlattname_tmp
     End If
     
     ZieldateiVorbereiten = True->Rückgabekennung OK
     
    AUFRAEUMEN:
    
    End Function
    '**********************************************************************************************
    Private Function AlleZeilenOhneSuchbegriffLoeschen(ws As Worksheet, _
                              Suchbegriff As Variant, _
                              InSpalt As Long, _
                              abZeile As Long, _
                              LetzteZeileAusSpalte As Long)
     
     Dim r As Range, Zelle As Range
     Dim lRows As Long
     
    ->letzte Zeile bestimmen
     lRows = ws.Cells(ws.Rows.Count, LetzteZeileAusSpalte).End(xlUp).Row
    ->keine Zeilen vorhanden -> Ende der Bearbeitung
     If lRows < abZeile Then GoTo AUFRAEUMEN->wenn
      
    ->letzte Zeile mit Länderkennung suchen
     Set Zelle = Nothing
     Set r = ws.Range(ws.Cells(abZeile, InSpalt), ws.Cells(lRows, InSpalt))
     Set Zelle = r.Find( _
      What:=Suchbegriff, _
      After:=ws.Cells(abZeile, InSpalt), _
      Lookat:=xlWhole, _
      SearchDirection:=xlPrevious)
    
    ->Nach dem Fundort bis zum Ende Zeilen löschen
     If Zelle Is Nothing Then
     ->keine Länderkennung gefunden -> alle Zeilen löschen
      ws.Rows(abZeile & : & lRows).Delete
     ElseIf Zelle.Row = lRows Then
     ->letzte Zeile -> nix machen
     Else
     ->gefunden
      ws.Rows((Zelle.Row + 1) & : & lRows).Delete
     End If
     
    ->------------------
     
    ->letzte Zeile bestimmen
     lRows = ws.Cells(ws.Rows.Count, LetzteZeileAusSpalte).End(xlUp).Row
    ->keine Zeilen vorhanden -> Ende der Bearbeitung
     If lRows < abZeile Then GoTo AUFRAEUMEN->wenn
     
    ->erste Zeile mit Länderkennung suchen
     Set Zelle = Nothing
     Set r = ws.Range(ws.Cells(abZeile, InSpalt), ws.Cells(lRows, InSpalt))
     Set Zelle = r.Find( _
      What:=Suchbegriff, _
      After:=ws.Cells(lRows, InSpalt), _
      Lookat:=xlWhole, _
      SearchDirection:=xlNext)
    
    ->Vor dem Fundort bis zum Anfang Zeilen löschen
     If Zelle.Row = abZeile Then
     ->erste Zeile -> nix machen
     Else
     ->gefunden
      ws.Rows(abZeile & : & (Zelle.Row - 1)).Delete
     End If
    
    AUFRAEUMEN:
     Set r = Nothing: Set Zelle = Nothing
    End Function
    Wo speicherst du das Makro ? Das kann in einer eigenen Excel-Datei geschehen. Diese muß dann zum Aufruf des Makros geöffnet sein.
    a) Neue Excel-Datei anlegen
    b) auf eine r Lasche -> rechte Maustaste -> Code anzeigen
    c) im Projekt-Fenster des VBA-Editors dieser Datei ein Modul hinzufügen
    (rechte Maus auf Projekt der Datei-> Einfügen -> Modul)
    d) in dieses Modul den gesamten Code aus dem Fenster oben per Copy Paste einfügen
    e) mit Alt+ Q VB-Editor schliessen
    f) Datei unter einem sinnigen Namen speichern, z.B. Makro CH und DE 1 sortiert.xls

    Adressen.xls öffnen
    Makro per Extras->Makro->Makros->AdrCHundDsortiert aufrufen

    Gruß Matjes :)
     
Die Seite wird geladen...

Excel Formel oder Makro - Ähnliche Themen

Forum Datum
Wie kann ich eine Excel-Formel in die nachfolgenden Zeilen mit variablem Multiplikator ziehen ? Microsoft Office Suite 4. Dez. 2015
Excel 2003 - Kleines Problem mit einer Formel Microsoft Office Suite 25. Juni 2014
Excel: Text in Formel umwandeln Windows XP Forum 21. Mai 2012
Excel 2000 Formel möglich Microsoft Office Suite 25. Apr. 2011
Excel 2000Formel oder Makro ? Windows XP Forum 14. März 2011