Excel Funktion

Dieses Thema Excel Funktion im Forum "Microsoft Office Suite" wurde erstellt von koksi, 21. Feb. 2006.

Thema: Excel Funktion habe da ein kleines kniffeliges Problem dass meinen kopf zum rauchen bringt und da ich auch nicht so der excel spezi...

  1. habe da ein kleines kniffeliges Problem dass meinen kopf zum rauchen bringt und da ich auch nicht so der excel spezi bin wende ich mich mal an euch


    also folgendes:

    habe da ne tabelle mit 15stelligen zahlen ziemlich viele und werden immer mehr z.b. so sieht es aus
    357693001771336
    357693002498129
    357999000311224
    ....
    ...
    ....



    und jetzt würde ich eine funktion brauchen die mir doppelte zahlen hervorhebt

    wenn zeile 10= 15 dann zeile 10 und 15 rot z.b.

    d.h. wenn irgend eine zahl schon vorhanden ist dann soll Excel sich irgnedwie bemerkbar machen (ROT, FETT oder ähnliches)

    jemand ne idee?

    danke
     
  2. Hallo koksi,

    schau mal unter
    http://www.wintotal-forum.de/index.php/topic,78895.0.html

    Das mit kleiner Anpassung sollte funktionieren.

    Wenn Du es nicht hinbekommst, schick mir eine Test-Datei an mein mailaddy. Dann bau ich es dir schnell ein.

    Gruß Matjes :)
     
  3. wäre echt super ich glaube das ist ein Level zu hoch für mich oder auch 2 oder 3 :)

    thx thx
     
  4. Also die 1.Version dazu :
    Code:
    Sub DoppelteZahlenSuchen()
    
      Const c_SPALTE = 3->entspricht Spalte c
      
      Dim ws As Worksheet
      Dim r_Range         As Range ->benutzter Bereich der Spalte
      Dim Zelle1          As Range ->Zelle deren Inhalt gesucht wird
      Dim Zelle2          As Range ->gefundenen Zelle, deren Inhalt mit Zelle1 übereinstimmt
      Dim r_DoppeltZelle1 As Range ->gemerkter Bereich doppelter Zellen bzgl.der momentanen Zelle
      Dim r_Doppelt       As Range ->gemerkter gesamter Bereich der doppelten Zellen
      
      Dim ersteAdresse As String
      
     ->aktives Blatt setzen
      Set ws = ActiveSheet
      
     ->benutzter Bereich der Spalte
      Set r_Range = Intersect(ws.Columns(c_SPALTE), ws.UsedRange)
      
     ->alle zellen prüfen
      For Each Zelle1 In r_Range
        
       ->nur 15stellige strings prüfen
        If Len(Zelle1.Value) = 15 Then
          
          Set r_DoppeltZelle1 = Nothing
         ->Suchen
          With r_Range
           ->nach der eigenen Zelle mit Suche beginnen
            Set Zelle2 = .Find(After:=Zelle1, What:=Zelle1.Value, LookIn:=xlValues, Lookat:=xlWhole)
            If Not Zelle2 Is Nothing Then
             ->Zelle selbst erstmal nicht berücksichtigen
              If Zelle1.Address <> Zelle2.Address Then
               ->erste Fundstelle merken
                ersteAdresse = Zelle2.Address
                
                Do
                  If r_DoppeltZelle1 Is Nothing Then
                   ->gefundene Zelle merken
                    Set r_DoppeltZelle1 = Zelle2
                  Else
                   ->gefundene Zelle den bereits gemerkten hinzufügen
                    Set r_DoppeltZelle1 = Union(r_DoppeltZelle1, Zelle2)
                  End If
                    
                 ->nächste suchen
                  Set Zelle2 = .FindNext(Zelle2)
                 ->nichts mehr gefunden ?
                  If Zelle2 Is Nothing Then Exit Do
                 ->Zelle selbst ?
                  If Zelle2.Address = Zelle1.Address Then Exit Do
                 ->wieder erste Fundstelle ?
                  If Zelle2.Address = ersteAdresse Then Exit Do
                Loop
                
               ->eine doppelte gefunden ?
                If Not r_DoppeltZelle1 Is Nothing Then
                 ->Zellen zum gesamten Doppelten Bereich hinzufügen
                  If r_Doppelt Is Nothing Then
                    Set r_Doppelt = Union(r_DoppeltZelle1, Zelle1)
                  Else
                    Set r_Doppelt = Union(r_Doppelt, r_DoppeltZelle1, Zelle1)
                  End If
                End If
              End If
            End If
          End With
        End If
      Next
    
     ->Wenn Doppelte vorhanden, dann fett,rot setzen
     ->entsprechende Ende-Meldung ausgeben
      If Not r_Doppelt Is Nothing Then
        With r_Doppelt: .Font.Bold = True: .Font.ColorIndex = 3: End With
        MsgBox _
          Doppelte Zahlen sind vorhanden. & vbLf & vbLf & _
          r_Doppelt.Count &  Kennzeichnungen wurden durchgeführt. & vbLf & vbLf & _
          Kennzeichen: fett, rot, _
          vbCritical
      Else
        MsgBox _
          Keine doppelte Zahlen vorhanden. :-) :-) :-)
      End If
      
    AUFRAEUMEN:
      Set ws = Nothing: Set r_Range = Nothing: Set Zelle1 = Nothing: Set Zelle2 = Nothing
      Set r_DoppeltZelle1 = Nothing: Set r_Doppelt = Nothing
    End Sub
    gruß Matjes :)
     
  5. und hier die 2. Version, deren Laufzeit sich im Gegensatz zur Version 1 bei wachsender Datensatzanzahl liniear vergrößert.

    Gruß Matjes :)
    Code:
    Option Explicit
    
    Sub DoppelteZahlenSuchen3()
    
      Const c_SPALTE = 3->entspricht Spalte c
      
      Dim ws As Worksheet, wst As Worksheet
      Dim r_Range         As Range ->benutzter Bereich der Spalte
      Dim Zelle           As Range
      Dim r_DoppeltZellen As Range ->gemerkter Bereich doppelter Zellen
      
      Dim ersteAdresse As String, l_row_anf As Long, l_row_end As Long, s_tmp As Long
      Dim d_test As Double, x As Long
      
     ->aktives Blatt setzen
      Set ws = ActiveSheet
      
     ->benutzter Bereich der Spalte
      Set r_Range = Intersect(ws.Columns(c_SPALTE), ws.UsedRange)
      
     ->Bildschirm-Update abstellen
      Application.ScreenUpdating = False
      
     ->temporäres Blatt anlegen
      Set wst = Worksheets.Add
      
     ->Format der ersten Spalte = Zahl ohne Nachkommastelle
      wst.Columns(1).NumberFormat = 0
      
     ->den zu untersuchenden Bereich hineinkopieren
      r_Range.Copy
      wst.Cells(1, 1).PasteSpecial _
                      Paste:=xlValues, _
                      Operation:=xlNone, _
                      SkipBlanks:=True, _
                      Transpose:=False
      
      wst.Columns(1).AutoFit
      
     ->Sortieren
      wst.Columns(1).Sort key1:=wst.Cells(1, 1), Order1:=xlAscending, Header:=xlNo
      
     ->alles was nicht Zahl und 15-stellig ist löschen
      On Error Resume Next
      For Each Zelle In wst.UsedRange
        d_test = Zelle.Value
        If Err.Number <> 0 Then
          Err.Clear: Zelle.Value = 
        Else
          If d_test < 100000000000000# Or d_test > 999999999999999# Then Zelle.Value = 
        End If
      Next
      wst.Columns(1).Sort key1:=wst.Cells(1, 1), Order1:=xlAscending, Header:=xlNo
      
     ->letzte Zeile bestimmen
      
     ->doppelte Zahlen bestimmen
      l_row_end = wst.Cells(wst.Rows.Count, 1).End(xlUp).Row
      For x = 1 To l_row_end
        If wst.Cells(x, 1).Value <> wst.Cells(x + 1, 1).Value Then wst.Cells(x, 1).Value = 
      Next
      wst.Columns(1).Sort key1:=wst.Cells(1, 1), Order1:=xlAscending, Header:=xlNo
      
     ->doppelte Zahlen nur einmal stehen lassen
      l_row_end = wst.Cells(wst.Rows.Count, 1).End(xlUp).Row
      For x = 1 To l_row_end
        If wst.Cells(x, 1).Value = wst.Cells(x + 1, 1).Value Then wst.Cells(x, 1).Value = 
      Next
      wst.Columns(1).Sort key1:=wst.Cells(1, 1), Order1:=xlAscending, Header:=xlNo
      
     -><<< jetzt sind nur noch doppelte Zahlen im Blatt enthalten >>>>
      l_row_end = wst.Cells(wst.Rows.Count, 1).End(xlUp).Row
      
     ->alle Zahlen im tatsächlichen Bereich suchen und Bereich merken
      Set r_DoppeltZellen = Nothing
      For x = 1 To l_row_end
        
       ->Suchen
        With r_Range
         ->nach der eigenen Zelle mit Suche beginnen
          Set Zelle = .Find(What:=wst.Cells(x, 1).Value, LookIn:=xlValues, Lookat:=xlWhole)
          If Not Zelle Is Nothing Then
           ->erste Fundstelle merken
            ersteAdresse = Zelle.Address
            
            Do
             ->gefundene Zelle merken
              If r_DoppeltZellen Is Nothing Then
                Set r_DoppeltZellen = Zelle
              Else
                Set r_DoppeltZellen = Union(r_DoppeltZellen, Zelle)
              End If
              
              Set Zelle = .FindNext(Zelle)                 'nächste suchen
              If Zelle Is Nothing Then Exit Do             'nichts mehr gefunden ?
              If Zelle.Address = ersteAdresse Then Exit Do->wieder erste Fundstelle ?
            Loop
          End If
        End With
      Next
    
     ->Wenn Doppelte vorhanden, dann fett,rot setzen
     ->entsprechende Ende-Meldung ausgeben
      If Not r_DoppeltZellen Is Nothing Then
        With r_DoppeltZellen: .Font.Bold = True: .Font.ColorIndex = 3: End With
        MsgBox _
          Doppelte Zahlen sind vorhanden. & vbLf & vbLf & _
          r_DoppeltZellen.Count &  Kennzeichnungen wurden durchgeführt. & vbLf & vbLf & _
          Kennzeichen: fett, rot, _
          vbCritical
      Else
        MsgBox Keine doppelte Zahlen vorhanden. :-) :-) :-)
      End If
      
    AUFRAEUMEN:
     ->temporäres Blatt löschen
      Application.DisplayAlerts = False
      wst.Delete
      Application.DisplayAlerts = True
     ->Bildschirm-Update anstellen
      Application.ScreenUpdating = True
    
      Set ws = Nothing
      Set r_Range = Nothing
      Set Zelle = Nothing
      Set r_DoppeltZellen = Nothing
      Set wst = Nothing
    End Sub
     
Die Seite wird geladen...

Excel Funktion - Ähnliche Themen

Forum Datum
Öffnen mit Doppelklick funktioniert bei Word u. Excel Dateien nichtmehr Microsoft Office Suite 10. Feb. 2015
Excel Dateien im Internet Explorer öffnen funktioniert nicht, trotz Registry-Eintrag Microsoft Office Suite 22. Juli 2013
Excel 2007 - Fehler in =TEXT Funktion ? Windows XP Forum 15. Jan. 2013
Summenfunktion mit Kriterium (Excel) Windows XP Forum 24. Juli 2012
Filesearch funktioniert ab Excel 2007 nicht mehr Microsoft Office Suite 16. Feb. 2012