höchsten Wert suchen

Bild

Betrifft: höchsten Wert suchen
von: Thomas
Geschrieben am: 19.06.2015 12:48:45

Hallo,
ich bin auf der suche nach einer VBA Lösung, dieses Makro sollte folgendes können.
Prüfe Wert in Spalte M und vergleiche diesen mit den Wert in gleicher Spalte aber nächster Zeile. Ist der Wert größer als der in der nächsten Zeile, so kopiere den Wert in ein neues Blatt und wechsele dort in die nächste Zeile ( die spalte ist egal ). Wiederhole den Vorgang bis zum Spaltenende und kopiere den letzte Wert ebenfalls in die neue Spalte ( wobei nur ein neues Blatt angelegt werden sollte, tue Anschließend das selbe mit Spalte n und danach mit spalte o) Cool wäre wenn man die Zeilennummer noch mit bekommen könnte ( in der der jeweilige Wert stand )
Es können bis zu 10000 Zeilen werden.
Da dies sehr speziell ist habe ich im Netz leider dazu nichts gefunden:
https://www.herber.de/bbs/user/98307.xlsm
lieben Dank schon mal im voraus
Thomas

Bild

Betrifft: AW: höchsten Wert suchen
von: fcs
Geschrieben am: 19.06.2015 14:29:15
Hallo Thomas,
nachfolgend ein entsprechendes Makro.
Gruß
Franz

Sub KopiereGroessere()
  Dim wks As Worksheet
  
  Dim wksZiel As Worksheet
  
  Dim arrData, ZeileDat As Long
  Dim arrErgebnis(), ZeileErg As Long
  Dim Spalte As Long
  
  Set wks = ActiveSheet
  For Spalte = 13 To 15 'M bis O
    With wks
      'letzte Datenzeile in Spalte
      ZeileDat = .Cells(.Rows.Count, Spalte).End(xlUp).Row
      If ZeileDat = 1 Then
        'Sonderfall nur Daten in Zeile 1 bzw. Spalte leer
        If .Cells(1, Spalte).Value <> "" Then
          ZeileErg = ZeileErg + 1
          ReDim Preserve arrErgebnis(1 To 2, 1 To ZeileErg)
          arrErgebnis(1, ZeileErg) = 1
          arrErgebnis(2, ZeileErg) = .Cells(1, Spalte).Value
        End If
      Else
        'Daten in Spalte in Array übernehmen
        arrData = .Range(.Cells(1, Spalte), .Cells(ZeileDat, Spalte))
        'Ergebnisarray vergrößern
        ReDim Preserve arrErgebnis(1 To 2, 1 To ZeileErg + ZeileDat)
        'Daten vergleichen und Ergebnisse in Array schreiben
        For ZeileDat = 1 To UBound(arrData, 1) - 1
          If arrData(ZeileDat, 1) > arrData(ZeileDat + 1, 1) Then
            ZeileErg = ZeileErg + 1
            arrErgebnis(1, ZeileErg) = ZeileDat
            arrErgebnis(2, ZeileErg) = arrData(ZeileDat, 1)
          End If
        Next
        'letzte Zeile ins Ergebnis-Array übernehmen
        ZeileErg = ZeileErg + 1
        arrErgebnis(1, ZeileErg) = UBound(arrData, 1)
        arrErgebnis(2, ZeileErg) = arrData(UBound(arrData, 1), 1)
        'Nicht benutzte Zeilen des Ergebnisarrays entfernen
        ReDim Preserve arrErgebnis(1 To 2, 1 To ZeileErg)
      End If
    End With
  Next
  'Ergebnis-Array in neues Tabellenblatt einfügen
  ActiveWorkbook.Worksheets.Add after:=wks
  Set wksZiel = ActiveSheet
  With wksZiel
    .Columns(1).ColumnWidth = 6
    .Columns(2).ColumnWidth = 12
    .Range("A1") = "Zeile"
    .Range("B1") = "Wert"
    .Range("A2").Resize(ZeileErg, 2) = Application.WorksheetFunction.Transpose(arrErgebnis)
  End With
End Sub


Bild

Betrifft: Cool Franz es funktioniert besten Dank
von: Thomas
Geschrieben am: 19.06.2015 14:42:55
Hallo Franz,
wie immer klasse Arbeit besten Dank.
Liebe Grüsse Thomas

Bild

Betrifft: Anderer Ansatz
von: Michael
Geschrieben am: 19.06.2015 15:12:01
Hi zusammen,
nachdem ich schon drangesessen bin, hier noch mein Ansatz:
Ich habe einige Hilfsspalten verformelt, kopiere die Formel bis ans Ende und die Werte dann ins Blatt "Auswertung", wo die Ergebnisse nach Zeilennummern sortiert werden.
Der Code ist überschaubar:

Option Explicit
Sub auswerten()
Dim unten&
unten = Range("M" & Rows.Count).End(xlUp).Row
Range("q1:x1").Copy Range("q1:q" & unten)
Range("q1:x" & unten).Copy
With Sheets("Auswertung")
  .Range("A1").PasteSpecial Paste:=xlPasteValues
  .Range("A1:B" & unten).Sort key1:=.Range("B1")
  .Range("D1:E" & unten).Sort key1:=.Range("E1")
  .Range("G1:H" & unten).Sort key1:=.Range("H1")
End With
End Sub
Gekürzte Datei anbei: https://www.herber.de/bbs/user/98314.xlsm
Schöne Grüße,
Michael

Bild

Betrifft: Nachfrage an Franz und Michael
von: Thomas
Geschrieben am: 19.06.2015 16:40:05
Hallo,
auch Dir Michael ein lieben lieben Dank ich habe nur noch das grösser kleiner Zeichen verdreht und es klappt auch super.
Leider habe ich nicht gut genug nachgedacht und durch den ansatz von michael habe ich einen veränderten ansatz.
das Blatt Auswertung ist in dem fall gut das ich mir beim import der daten nicht immer meine anderen formeln zerschiesse. Bekommt man das hin das ich die Werte der Spalten A und B der betroffenen Werte noch mit rüber bekomme.
Franz falls du das macro nochmal anfassen tust währe klasse wenn die Daten nicht in ein neues Tabellenblatt sondern ins Tabellenblatt Abrechnung landen (welches ich dann noch anlege).
Michael wäre auch super wenn Du dir dies auch nochmal anschaust( Werte aus Spalte A und B ) Dein Ansatz kann ich noch (zusätzlich) prima für eine andere Geschichte benutzen.
Bitte entschuldigt das ich dies erst im nachgang frage mein erster Ansatz war ein wenig un überlegt.
liebe grüsse Thomas


Bild

Betrifft: AW: Nachfrage an Franz und Michael
von: fcs
Geschrieben am: 20.06.2015 09:42:18
Hallo Thomas,
hier das Makro angepasst, so dass Daten im Blatt "Abrechnung" eingetragen werden und zusätzlich die Werte aus den Spalten A und B übernommen werden.
Gruß
Franz

Sub KopiereGroessere()
   Dim wks As Worksheet
   
   Dim wksZiel As Worksheet
   
   Dim arrData, ZeileDat As Long
   Dim arrErgebnis(), ZeileErg As Long
   Dim Spalte As Long
   
   Set wks = ActiveSheet
   Set wksZiel = ActiveWorkbook.Worksheets("Abrechnung")
   
        
   For Spalte = 13 To 15 'M bis O
        With wks
            'letzte Datenzeile in Spalte
            ZeileDat = .Cells(.Rows.Count, Spalte).End(xlUp).Row
            If ZeileDat = 1 Then
              'Sonderfall nur Daten in Zeile 1 bzw. Spalte leer
              If .Cells(1, Spalte).Value <> "" Then
                ZeileErg = ZeileErg + 1
                ReDim Preserve arrErgebnis(1 To 2, 1 To ZeileErg)
                arrErgebnis(1, ZeileErg) = 1
                arrErgebnis(2, ZeileErg) = .Cells(1, Spalte).Value
              End If
            Else
              'Daten in Spalte in Array übernehmen
              arrData = .Range(.Cells(1, Spalte), .Cells(ZeileDat, Spalte))
              'Ergebnisarray vergrößern
              ReDim Preserve arrErgebnis(1 To 2, 1 To ZeileErg + ZeileDat)
              'Daten vergleichen und Ergebnisse in Array schreiben
              For ZeileDat = 1 To UBound(arrData, 1) - 1
                If arrData(ZeileDat, 1) > arrData(ZeileDat + 1, 1) Then
                  ZeileErg = ZeileErg + 1
                  arrErgebnis(1, ZeileErg) = ZeileDat
                  arrErgebnis(2, ZeileErg) = arrData(ZeileDat, 1)
                End If
              Next
              'letzte Zeile ins Ergebnis-Array übernehmen
              ZeileErg = ZeileErg + 1
              arrErgebnis(1, ZeileErg) = UBound(arrData, 1)
              arrErgebnis(2, ZeileErg) = arrData(UBound(arrData, 1), 1)
              'Nicht benutzte Zeilen des Ergebnisarrays entfernen
              ReDim Preserve arrErgebnis(1 To 2, 1 To ZeileErg)
            End If
        End With
   Next
   
   'Ergebnis-Werte ab Zelle A2 eintragen
   Application.ScreenUpdating = False
   With wksZiel.Range("A2")
        ZeileDat = .Parent.Cells(.Parent.Rows.Count, .Column).End(xlUp).Row
        'Altdaten löschen
        If ZeileDat >= .Row Then
           .Offset(0, 0).Resize(ZeileDat - .Row + 1, 4).ClearContents
        End If
        If ZeileErg > 0 Then
            'Ergebnis-Array in Blatt "Abrechnung" einfügen
             .Resize(ZeileErg, 2) = Application.WorksheetFunction.Transpose(arrErgebnis)
             'eingefügte Daten nach Zeilen-Nummer sortieren - ggf.die nächsten 3 Zeilen  _
aktivieren
'             With .Resize(ZeileErg, 2)
'                .Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlNo
'             End With
             'Werte aus Spalten A und B  per Formel übernehmen und Formeln durch Werte ersetzen
             With .Offset(0, 2).Resize(ZeileErg, 2)
                .FormulaR1C1 = "=INDEX('" & wks.Name & "'!C1:C2,RC1,COLUMN(RC[" & (-.Column + 1) _
 & "]))"
                .Calculate
                .Copy
                .PasteSpecial Paste:=xlPasteValues
                Application.CutCopyMode = False
             End With
        End If
         'Spaltentitel eintragen
'        .Offset(-1, 0) = "Zeile"
'        .Offset(-1, 1) = "Wert"
'        .Offset(-1, 2) = "Datum"
'        .Offset(-1, 3) = "Wert B"
        .Parent.Activate
        .Select
   End With
   Application.ScreenUpdating = True
   
End Sub


Bild

Betrifft: Franz besten Dank
von: Thomas
Geschrieben am: 20.06.2015 12:33:28
Hallo Franz,
besten Dank für deine Gedult und schnelle Hilfe. Es klappt bestens super.
liebe Grüssen Thomas

Bild

Betrifft: Franz besten Dank
von: Thomas
Geschrieben am: 20.06.2015 12:36:40
Hallo Franz,
besten Dank für deine Gedult und schnelle Hilfe. Es klappt bestens super.
Auch für die anpassungsmöglichkeiten. Einfach nur klasse.
liebe Grüssen Thomas

Bild

Betrifft: AW: Nachfrage an Franz und Michael
von: Michael
Geschrieben am: 20.06.2015 13:36:10
Hallo zusammen,
ich hab mir's auch noch mal angesehen. Mit dem Tauschen des kleiner/größer war's nicht getan, ich habe die Formel geändert.
Und einige Hilfsspalten angefügt, um eine weitere Idee umzusetzen, wegen der Spalten A+B. Es gibt zwei Möglichkeiten, das auszugeben: bitte zu probieren.
Datei: https://www.herber.de/bbs/user/98328.xlsm
Schöne Grüße,
Michael

Bild

Betrifft: Besten Dank an Michael
von: Thomas
Geschrieben am: 21.06.2015 16:33:05
Hallo Michael,
super das Du Dir dies noch mal angeschaut und überarbeitet hast. Mir ist dies garnicht aufgefallen.
vielen Dank damit kann ich richtig viel anfangen.
liebe grüsse Thomas

Bild

Betrifft: na, das freut mich, danke für die Info
von: Michael
Geschrieben am: 22.06.2015 16:44:29
und LG zurück,
Michael

 Bild

Beiträge aus den Excel-Beispielen zum Thema "höchsten Wert suchen"