Zeilenminimum mit VBA -Code abändern

Bild

Betrifft: Zeilenminimum mit VBA -Code abändern
von: Bonduca
Geschrieben am: 11.08.2015 07:57:55

Hallo zusammen,
ich möchte aus jeder Zeile das Zeilenminimum (oder bei Bedarf auch den zweitkleinsten Wert) herauslesen.
Ich habe den untenstehenden Code abgeändert und noch folgende Probleme damit:
1. er soll keine 0 Werte berücksichtigen (und als Minimum ausweisen), sondern nur Werte die größer als 0 sind.
2. als Ergebnis liefert er die Spalte und Zeile (z.B. "$I$16). Gibt es eine Möglichkeit, dass er mir den Text in Zeile 15 (also in dem Fall den Inhalt von I15 wieder gibt)?

Sub ZeileMinimumAdresse()                       ' Suche Minimum von links beginnend
Dim strRange As String                          ' Bereich Zeile von B bis IV
Dim i As Long
Dim intMinNr As Integer
Dim objWks As Object                            ' Tabellenblatt mit Werte
With Application
   Set objWks = .ThisWorkbook.Worksheets(1)    ' erstes Tabellenblatt
                              
   For i = 16 To objWks.Range("G" & Rows.Count).End(xlUp).Row
   
        
        intMinNr = 1                               ' das wievielte Minimum (Rang)
        On Error Resume Next                    ' eventuelle Leerzeilen erzeugen Fehler
        strRange = "G" & i & ":IV" & i          ' Spalte A: Adresse des Minimums
        
        
         objWks.Cells(i, 1) = objWks.Range(strRange).Find(.WorksheetFunction.Small(objWks.Range( _
strRange), intMinNr), LookAt:=xlWhole, LookIn:=xlValues).Address
       
     
    Next i
End With
On Error GoTo 0                                  ' Fehlerbehandlung wieder Standard
End Sub
Danke und viele Grüße!

Bild

Betrifft: AW: Zeilenminimum mit VBA -Code abändern
von: Michael
Geschrieben am: 11.08.2015 17:39:30
Hi Bonduca,
das 1. ist ziemlich simpel; Du brauchst nur vor dem Next i die Zeile einzufügen...

objWks.Cells(i, 2) = Range(objWks.Cells(i, 1)).Value

... wenn Du die Werte in Spalte B haben willst. Wenn Du die Adresse gar nicht brauchst, ersetzt Du die (i,2) links vom = durch (i,1), dann wird die Adresse durch den Wert überschrieben.
*Oder* Du ersetzt das ".Address" in der Zeile vorher durch ".Value", dann hast Du den Wert gleich in Spalte A und brauchst keine weitere Zeile.
2. ist vielleicht einfacher zu lösen, aber ich programmiere lieber eine Schleife als mir Formeln auszudenken:
Option Explicit
Sub ZeileMinimumAdresse_ganzNeu()                       ' Suche Minimum von links beginnend
Dim strRange As String                          ' Bereich Zeile von B bis IV
Dim i As Long, j As Long, k As Long
Dim objWks As Object                            ' Tabellenblatt mit Werte
Dim Vwerte As Variant
Dim c As Range
Const linkeSpalte = "G", rechteSpalte = "IV"    ' "zentrale" Definition
Const intMinNr = 1                               ' das wievielte Minimum (Rang)
With Application
   Set objWks = .ThisWorkbook.Worksheets(1)    ' erstes Tabellenblatt
   
   On Error Resume Next                    ' eventuelle Leerzeilen erzeugen Fehler
        
   For i = 16 To objWks.Range("G" & Rows.Count).End(xlUp).Row
        
        strRange = linkeSpalte & i & ":" & rechteSpalte & i
        
        ' s. Kommentar 1
        j = objWks.Range(rechteSpalte & "1").Column - _
            objWks.Range(linkeSpalte & "1").Column + 1
            
        ' s. Kommentar 2
        Vwerte = objWks.Range(strRange)
        For k = 1 To j
           If Not IsNumeric(Vwerte(1, k)) Then
              Vwerte(1, k) = ""
            Else
             If Vwerte(1, k) <= 0 Then
              Vwerte(1, k) = ""
             End If
           End If
        Next
        Set c = objWks.Range(strRange). _
          Find(.WorksheetFunction.Small(Vwerte, intMinNr), _
          LookIn:=xlValues)
          
        ' s. Kommentar 3
        If Not c Is Nothing Then
           objWks.Cells(i, 1) = c.Value
           objWks.Cells(i, 2) = c.Address
          Else
           objWks.Cells(i, 1) = "n.v."
        End If
        
'        objWks.Cells(i, 1) = objWks.Range(strRange). _
'          Find(.WorksheetFunction.Small(Vwerte, intMinNr), _
'          LookIn:=xlValues).Address
'        objWks.Cells(i, 2) = Range(objWks.Cells(i, 1)).Value
     
    Next i
End With
On Error GoTo 0                                  ' Fehlerbehandlung wieder Standard
End Sub
Kommentar 1: ich habe die Spalten zur einfachen, zentralen Änderung in eine Konstante gepackt.
(Die folgenden Zeilen sind eine Krücke, um die Anzahl der Werte bzw. den "Abstand" zwischen beiden Spalten zu ermitteln. Normalerweise ermittelt man die Größe eines Arrays mit Ubound(), das gibt aber trotz Recherche standhaft nur 1 aus.)
Kommentar 2: die "Zeile" mit Werten werden in ein Array gesteckt, das so gesehen eine Kopie der Daten enthält und gefahrlos bearbeitet werden kann: alles, was nicht numerisch bzw. kleinergleich 0 ist, wird geleert: "".
Die .Small-Funktion arbeitet dann mit Werten >0, und Fehler sollten eigentlich ausgeschlossen sein.
Kommentar 3: Ich habe die vorhandenen Zeilen auskommentiert und mit einer Suche ersetzt, die als Ergebnis die Zelle (den Range) c zurückgibt.
Diese *kann* nämlich leer sein, auch wenn tatsächlich ein Wert vorhanden ist: ich hatte zum Testen einen Bereich mit Zufallszahlen von -5 bis 95 gefüllt, und .find findet bei krummen Werten mit vielen Nachkommastellen nämlich rein gar nichts. Find hatte erst dann funktioniert, als ich alle Werte gerundet hatte (konkret auf 6 Nachkommastellen). Damit wir uns nicht mißverstehen: *nicht* auf 6 Nachkommastellen *formatiert*, sondern tatsächlich *gerundet*.
Jedenfalls kann man abfragen, ob c eine gefundene Zelle oder nothing ist und entsprechend darauf reagieren.
*Falls* Du wirklich nur den Wert und nicht die Adresse benötigst, kannst Du alles zwischen den beiden Next auskommentieren und durch die Zeile:
objWks.Cells(i, 1) = .WorksheetFunction.Small(Vwerte, intMinNr)

ersetzen, dann umgehst Du sämtliche, potentiellen Schwierigkeiten mit dem Find.
Schöne Grüße,
Michael

Bild

Betrifft: AW: Zeilenminimum mit VBA -Code abändern
von: Bonduca
Geschrieben am: 12.08.2015 09:25:35
Wow. Ich bin komplett von den Socken! Vielen Dank für die Arbeit, die du da rein gesteckt hast. Es funktioniert einwandfrei!
Eine klitzekleine Frage hätte ich noch:
Kann ich vielleicht mit Hilfe der Spaltenadresse, die mir in Spalte B ausgegeben wird, die "Überschrift" des niedrigsten Wertes in zeile 15 auslesen und mir in die jeweilige Zeile in Spalte C ausgeben lassen?
Kleines Beispiel:


						Äpfel	Birnen	Melonen
1	$G$16	Äpfel				1	2	3
1	$H$17	Birnen				2	1	3
Danke! :D

Bild

Betrifft: 1. gerne, 2. Weiteres
von: Michael
Geschrieben am: 12.08.2015 13:47:41
Hi Bonduca,
freut mich, wenn es funzt.
Die Erweiterung geht im Handumdrehen:
Du fügst oben bei den Deklarationen eine weitere Konstante ein

Const UeberZeile = 15                           ' die Zeile mit den Überschriften

mit der Zeilennummer, in der die Überschriften stehen, und eine weitere Anweisung in dem passenden Zweig, hier dann der komplette Teil:
        If Not c Is Nothing Then
           objWks.Cells(i, 1) = c.Value
           objWks.Cells(i, 2) = c.Address
           objWks.Cells(i, 3) = objWks.Cells(UeberZeile, c.Column)
          Else
           objWks.Cells(i, 1) = "n.v."
        End If
Das schöne an der Suche mit c ist, daß für c alles zur Verfügung steht, was das Range-Objekt hergibt: in dem Fall werten wir denn die drei Eigenschaften .Value, .Address und .Column aus.
Nimm Dir doch mal ne halbe Stunde Zeit und sieh Dir den Objekt-Inspektor an (im VB-Editor Taste F2 - zurück in den Code geht es mit F7): da blätterst Du dann runter bis Range und siehst Dir alle Eigenschaften und Methoden an.
Eine Spielerei wäre z.B., eine weitere Anweisung im Then-Block einzufügen...
c.Interior.Color = vbYellow

...dann werden alle Treffer gelb markiert.
Usw. System kapiert?
Happy Exceling,
Michael

Bild

Betrifft: Danke!! Funktioniert das auch mit Kommazahlen?
von: Bonduca
Geschrieben am: 13.08.2015 08:23:21
Hallo Michael,
danke für dein Zeit und deine Erklärungen. Da hab ich wirklich was dazugelernt.
Was ich jedoch nicht hinbekomme (bin ja leider noch Anfänger) ist, dass c auch Kommazahlen verwertet. Wenn nur Kommazahlen in Zeilen stehen, dann wird in Spalte A "n.v" ausgegeben.
Ich hab schon versucht mit der Definition der Variablen herumzuspielen, aber dann ist der Code auf einen Fehler gelaufen.
Kann man das noch ändern?
Wenn es nicht geht, dann ist es nicht schlimm, dann runde ich einfach alle Werte im Tabellenblatt.
Der Code hier bringt mich schon einiges weiter :)

Bild

Betrifft: Liest Du auch alles?
von: Michael
Geschrieben am: 13.08.2015 18:17:22
Hi Bonduca,
ich hatte doch geschrieben, daß viele Dezimalzahlen Ärger machen.
Nur weil's mich gejuckt hat, hier ne andere Lösung mit Bubblesort (und ganz ohne .Find):

Option Explicit
Sub ZeileMinimumAdresse_ganzganzNeu()           ' Suche Minimum von links beginnend
Dim strRange As String                          ' Bereich Zeile von B bis IV
Dim i As Long, j As Long, k As Long, m&
Dim objWks As Object                            ' Tabellenblatt mit Werte
Dim Vwerte As Variant
Dim tmp(1 To 2) As Variant
Dim c As Range
Dim ii&, jj&
Const linkeSpalte = "G", rechteSpalte = "IV"    ' "zentrale" Definition
Const intMinNr = 1                               ' das wievielte Minimum (Rang)
Const UeberZeile = 15                           ' die Zeile mit den Überschriften
Const min = 0
With Application
   Set objWks = .ThisWorkbook.Worksheets(1)    ' erstes Tabellenblatt
   
   On Error Resume Next                    ' eventuelle Leerzeilen erzeugen Fehler
 
   j = objWks.Range(rechteSpalte & "1").Column - _
       objWks.Range(linkeSpalte & "1").Column + 1
         
   For i = 16 To objWks.Range("G" & Rows.Count).End(xlUp).Row
        strRange = linkeSpalte & i & ":" & rechteSpalte & i + 1
        Vwerte = objWks.Range(strRange)
        m = 0
        For k = 1 To j
           Vwerte(2, k) = k
           If IsNumeric(Vwerte(1, k)) And Vwerte(1, k) > min Then
             m = m + 1
             Vwerte(1, m) = Vwerte(1, k)
             Vwerte(2, m) = Vwerte(2, k)
           End If
        Next k
        
        If m > 0 And m >= intMinNr Then
            ReDim Preserve Vwerte(2, m)
    
    '       Bubblesort ***********
            For ii = 1 To m
              For jj = ii + 1 To m
               If Vwerte(1, ii) > Vwerte(1, jj) Then
                 For k = 1 To 2
                  tmp(k) = Vwerte(k, ii)
                  Vwerte(k, ii) = Vwerte(k, jj)
                  Vwerte(k, jj) = tmp(k)
                 Next k
                End If
              Next
            Next
            
   '       If intMinNr <= m Then ' oben abgefragt
          ' d.h. wenn Du den 4.kleinsten Wert haben willst, aber
          ' in Vwerte tatsächlich nur 3 enthalten sind...
           Set c = objWks.Range(strRange)(1, Vwerte(2, intMinNr))
           objWks.Cells(i, 1) = c.Value
           objWks.Cells(i, 2) = c.Address
           objWks.Cells(i, 3) = objWks.Cells(UeberZeile, c.Column)
           c.Interior.Color = vbYellow
          Else
           objWks.Cells(i, 1) = "n.v."
           objWks.Cells(i, 2) = "intMinNr = " & intMinNr
           objWks.Cells(i, 3) = "Werte >0: " & m
        End If
    Next i
End With
On Error GoTo 0                                  ' Fehlerbehandlung wieder Standard
End Sub
Schöne Grüße,
Michael

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Duplikate"