Herbers Excel/VBA-Archiv

VBA: Maximum suchen und Zeile kopieren

• VBA: Maximum suchen und Zeile kopieren von Marcel vom 24.08.2014 14:24:05
• AW: VBA: Maximum suchen und Zeile kopieren - von Christian am 24.08.2014 14:33:12
  • AW: VBA: Maximum suchen und Zeile kopieren - von Marcel am 24.08.2014 15:35:31
• Kopieren per VBA-Einzeiler - von NoNet am 24.08.2014 14:38:20
  • Variante : ALLE Zeilen bei multiplen MAX kopieren - von NoNet am 24.08.2014 15:07:56
    • AW: Variante : ALLE Zeilen bei multiplen MAX kopieren - von Marcel am 24.08.2014 15:56:06
• AW: VBA: Maximum suchen und Zeile kopieren - von Adis am 24.08.2014 16:10:54
  • AW: VBA: Maximum suchen und Zeile kopieren - von Adis am 26.08.2014 21:32:02

Betrifft: VBA: Maximum suchen und Zeile kopieren von: Marcel
Geschrieben am: 24.08.2014 14:24:05

Hallo,
Ich habe ein kleines Problem in VBA:
Ich möchte im angehängten File im Bereich B2 bis H6 das Maximum finden (hier wäre das in E4) und dann von der Zeile in dem das Max ist (4) die Einträge B4 bis H4 in eine neue Zeile, z.B. 9 kopieren.
Das Maximum muss nicht immer mittig sein, es kann auch am Rand liegen, aber ich brauche immer nur die Zeile und daraus die Einträge B bis H in einer neuen Zeile.

Ich hoffe man versteht mich ^^

https://www.herber.de/bbs/user/92262.xlsx

Betrifft: AW: VBA: Maximum suchen und Zeile kopieren von: Christian
Geschrieben am: 24.08.2014 14:33:12

Hallo Marcel,

drei kurze Fragen:
Willst Du eine Art fortlaufende Liste erstellen?
Kommt das Maximun nur einmal vor oder ist es möglich, das mehrere Maxima vorhanden sind?
Muss es unbedingt VBA sein, oder reicht auch eine Formellösung? (was nur geht, falls Du die erste Frage mit Nein beantwortest ;-) )

MfG Christian

Betrifft: AW: VBA: Maximum suchen und Zeile kopieren von: Marcel
Geschrieben am: 24.08.2014 15:35:31

Das wird keine fortlaufende Liste. Es gibt nur diese eine Matrix und ich benötige nur die Zeile mit dem Maximum. Es gibt auch nur ein einziges Maximum.
Eine Formellösung würde natürlich auch gehen. In VBA wäre es aber interessant zu sehen wie das gelöst werden kann :)

Betrifft: Kopieren per VBA-Einzeiler von: NoNet
Geschrieben am: 24.08.2014 14:38:20

Hallo Marcel,

die VBA-Kurzform ist tatsächlich nur ein Einzeiler :

Intersect([B:H], [B2:H6].Find(Application.Max([B2:H6])).EntireRow).Copy [B9]

Oder etwas ausführlicher :

Sub Maximum_Kopieren()
    'NoNet, 24.08.2014
    'Einzeilige Kurzform :
    'Intersect([B:H], [B2:H6].Find(Application.Max([B2:H6])).EntireRow).Copy [B9]

    Dim rngBereich As Range, rngZeile As Range, rngZiel As Range
    
    Set rngBereich = [B2:H6]    'Wertebereich
    Set rngZiel = [B9]          'Zielbereich
    
    Set rngZeile = rngBereich.Find(Application.Max(rngBereich)).EntireRow
    Set rngZeile = Intersect(rngBereich.EntireColumn, rngZeile)
    
    rngZeile.Copy rngZiel
End Sub

Salut, NoNet

Betrifft: Variante : ALLE Zeilen bei multiplen MAX kopieren von: NoNet
Geschrieben am: 24.08.2014 15:07:56

Hallo Marcel,

hier noch eine Erweiterung :
Falls der MAX-Wert im Bereich mehrfach vorhanden ist, werden mit folgendem Makro ALLE entsprechenden Zeilen kopiert :

Sub Multiple_Maximum_Kopieren()
    'NoNet, 24.08.2014
    'Alle MAX-Zeilen Kopieren

    Dim rngBereich As Range, rngZeile As Range, rngZiel As Range
    Dim rngZelle As Range, strErsteZelle As String
        
    Set rngBereich = [B2:H6]    'Wertebereich
    Set rngZiel = [B9]          'Zielbereich
    
    Set rngZelle = rngBereich.Find(Application.Max(rngBereich))
    Set rngZeile = rngZelle.EntireRow
    strErsteZelle = rngZelle.Address
    
    Do
        Set rngZelle = rngBereich.FindNext(after:=rngZelle)
        If rngZelle.Address <> strErsteZelle Then
            Set rngZeile = Union(rngZeile, rngZelle.EntireRow)
        End If
    Loop Until rngZelle.Address = strErsteZelle
    
    Set rngZeile = Intersect(rngBereich.EntireColumn, rngZeile)
    
    rngZeile.Copy rngZiel
End Sub

Ciao, NoNet

Betrifft: AW: Variante : ALLE Zeilen bei multiplen MAX kopieren von: Marcel
Geschrieben am: 24.08.2014 15:56:06

Hallo Nonet,
Vielen Dank für deine Hilfe. Wenn ich den Einzeiler benutze erhalte ich leider folgenden Fehler:
Objektvariable oder With-Blockvariable nicht festgelegt.

Betrifft: AW: VBA: Maximum suchen und Zeile kopieren von: Adis
Geschrieben am: 24.08.2014 16:10:54

Hallo

kurz und knapp in einer kleinen Beispiel Datei. Bitte anschauen ob es so gemeint war.

ttp://www.herber.de/bbs/user/92264.xls

gruss Adis

Betrifft: AW: VBA: Maximum suchen und Zeile kopieren von: Adis
Geschrieben am: 26.08.2014 21:32:02

Hallo

Falls sich die Beispiel Datei nicht öffnen laesst hier der Makro Code.
Einfach in ein normales Modul Blatt kopieren und ausprobieren.

Option Explicit '24.8.2014

Const Bereich = "B2:H6"
Const ListAnf = "B9"

Sub Maximum_kopieren()
Dim Zeile, Max, i
 Sheets("Tabelle1").Select
'Schleife für Max Wert ermitteln
For Each i In Range(Bereich)
   If i.Value > Max Then
      Max = i.Value
      Zeile = i.Row
   End If
Next i
'gefunden Zeile in B9 kopieren
Cells(Zeile, "B").Resize(1, 7).Copy
Range(ListAnf).PasteSpecial xlValues
Application.CutCopyMode = False
End Sub

Gruss Adis

Beiträge aus den Excel-Beispielen zum Thema "VBA: Maximum suchen und Zeile kopieren"