Live-Forum - Die aktuellen Beiträge
Datum
Titel
19.07.2024 18:36:17
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA: Maximum suchen und Zeile kopieren

VBA: Maximum suchen und Zeile kopieren
24.08.2014 14:24:05
Marcel

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

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA: Maximum suchen und Zeile kopieren
24.08.2014 14:33:12
Christian
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

AW: VBA: Maximum suchen und Zeile kopieren
24.08.2014 15:35:31
Marcel
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 :)

Anzeige
Kopieren per VBA-Einzeiler
24.08.2014 14:38:20
NoNet
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

Anzeige
Variante : ALLE Zeilen bei multiplen MAX kopieren
24.08.2014 15:07:56
NoNet
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

Anzeige
AW: Variante : ALLE Zeilen bei multiplen MAX kopieren
24.08.2014 15:56:06
Marcel
Hallo Nonet,
Vielen Dank für deine Hilfe. Wenn ich den Einzeiler benutze erhalte ich leider folgenden Fehler:
Objektvariable oder With-Blockvariable nicht festgelegt.

AW: VBA: Maximum suchen und Zeile kopieren
24.08.2014 16:10:54
Adis
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

AW: VBA: Maximum suchen und Zeile kopieren
26.08.2014 21:32:02
Adis
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

Anzeige

372 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige