Zeilenminimum mit VBA -Code abändern

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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)

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

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

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 0: " & m End If Next i End With On Error GoTo 0 ' Fehlerbehandlung wieder Standard End Sub

Beliebteste Forumthreads (12 Monate)

Zeilenminimum mit VBA -Code abändern

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

305 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zeilenminimum mit VBA -Code abändern

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

305 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread