min mit vba

hallo leute,
wieder mal stehe ich vor einem problem und hoffe auf eure hilfe.
in ein tabellenblatt übertrage ich daten von spalte A - I. die zeilenmenge ist variabel. mal sind es 10 datensätze mal aber auch 99 oder mehr.in spalte A befinden sich Artikelnummern, welche auch mehrfach vorkommen können. nun möchte ich am ende der einträge die kleinste zahl aus spalte A anzeigen. das wollte ich mit der min-formel lösen, leider kenne ich den darüber liegenden bereich nicht und komme da irgendwie nicht weiter.
die zelle ermittle ich mit:
Cells(ActiveCell.Row + 1, 1).Select
und dort soll diese formel dann wirksam werden, wobei die R[-45] eine variable größe ist
ActiveCell.FormulaR1C1 = "=MIN(R[-3]C:R[-45]C)"
vielleicht hat ja jemand eine idee, mir qualmt schon seit stunden der kopf und bei der recherche habe ich leider auch nichts passendes gefunden.
viele grüße kirsche

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Public Sub test() Dim erste_Freie As Range Set erste_Freie = Range("A65536").End(xlUp).Offset(1, 0) erste_Freie.Formula = "=min(A2:" & erste_Freie.Offset(-1, 0).Address & ")" erste_Freie.Offset(1, 0).Formula = "=SMALL(A2:" & erste_Freie.Offset(-1, 0).Address & ",2)" _ _ b> End Sub Grüße Gerd

Public Sub test() Dim erste_Freie As Range, i As Long Set erste_Freie = Range("A65536").End(xlUp).Offset(1, 0) For i = 1 To Range("A65536").End(xlUp).Row - 1 '# oder z.B. .. to 5 erste_Freie.Offset(i - 1, 0).Formula = _ "=SMALL(A2:" & erste_Freie.Offset(-1, 0).Address & "," & i & ")" Next End Sub

Public Sub test() Dim erste_Freie As Range, i As Long Set erste_Freie = Range("A65536").End(xlUp).Offset(1, 0) For i = 1 To Range("A65536").End(xlUp).Row - 1 '# oder z.B. .. to 5 erste_Freie.Offset(i - 1, 0).Formula = _ "=SMALL(A2:" & erste_Freie.Offset(-1, 0).Address & "," & i & ")" Next For i = Range("A65536").End(xlUp).Row To erste_Freie.Offset(1, 0).Row Step -1 If Cells(i, 1).Value = Cells(i - 1, 1).Value Then 'doppelte löschen Cells(i, 1).Delete shift:=xlUp Else 'Formeln wieder entfernen Cells(i, 1).Value = Cells(i, 1).Value End If Next 'Formel in erster Zelle entfernen erste_Freie.Value = erste_Freie.Value End Sub

Sub test Dim ez As Long, lz As Long, ez2 As Long ez= 5 lz= Cells(ez,1).End(xlDown).Row ez2= lz+ 1 Range("A" & ez & ":" & "A" & lz).AdvancedFilter Action:=xlFilterCopy, copytorange:=Range("A" & _ ez2), _ Unique:=True Range("A" & ez2 & ":" & "A" & Cells(ez2, 1).End(xlDown).Row).Sort Key1:= Cells(ez2,1), _ Order1:=xlAscending, Header:= xlYes Cells(ez2,1).Delete shift:=xlUp End Sub

hallo gerd,
ist ja lustig, nun funzt es aber meine 2. & 3. überschrift wird nun auch noch mit übertragen. das sollte eigentlich nicht sein. ich schick dir mal den ganzen code.


Private Sub Worksheet_Activate()
'alte einträge löschen
Range("K7:N2500").ClearContents
Range("A7:I2500").ClearContents
Range("A7:I7").Copy
Range("A8:I2500").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
'übersichtsbeleg
Dim Aletzte As Long, i As Long, j As Long
Dim wks3 As Worksheet, wks4 As Worksheet
Application.ScreenUpdating = False
Set wks3 = Sheets("Eingabe")
Set wks4 = ActiveSheet
j = 7
Aletzte = IIf(IsEmpty(wks3.Range("A65536")), wks3.Range("A65536").End(xlUp).Row, 65536)
For i = 4 To Aletzte
' 4 = Spalte der Lieferantennummer anpassen gegebenenfalls
'1 = Zeile und 1 = Spalte der Lieferantennummer
If wks3.Cells(i, 20).Value = wks4.Cells(3, 1).Value Then
'j = ab zeile 7 übertragen
wks3.Range("E" & i & ":H" & i).Copy
wks4.Range("A" & j & ":D" & j).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks _
:=False, Transpose:=False
wks3.Range("M" & i & ":N" & i).Copy
wks4.Range("E" & j & ":F" & j).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks _
:=False, Transpose:=False
wks3.Range("J" & i & ":K" & i).Copy
wks4.Range("G" & j & ":H" & j).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks _
:=False, Transpose:=False
wks3.Range("D" & i).Copy
wks4.Range("I" & j).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,  _
SkipBlanks _
:=False, Transpose:=False
j = j + 1
End If
Next i
'gesamtübersichtsbeleg
'erste freie zelle ermitteln und überschrift eintragen und formatieren
Dim lLetzte  As Long
lLetzte = IIf(Range("A65536")  "", 65536, Range("A65536").End(xlUp).Row)
Range("A" & lLetzte + 1).Value = "R e t o u r e  -  G e s a m t b e l e g"
Range("I" & lLetzte + 1).Value = "Sammelretoure 1 x monatlich"
Range("A" & lLetzte + 2).Value = "fFZ art.Nr."
Range("B" & lLetzte + 2).Value = "Artikelbezeichnung"
Range("C" & lLetzte + 2).Value = "Inhalt/Ein"
Range("D" & lLetzte + 2).Value = "heit"
Range("E" & lLetzte + 2).Value = "Gesamt-Menge"
Range("F" & lLetzte + 2).Value = "Lief.Art.Nr."
With Range("A" & lLetzte + 1).Font
.Size = 16
.FontStyle = "Fett"
.Underline = xlUnderlineStyleSingle
End With
With Range("A" & lLetzte + 1)
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With
With Range("I" & lLetzte + 1).Font
.Size = 10
.FontStyle = "Fett"
End With
With Range("I" & lLetzte + 1)
.HorizontalAlignment = xlRight
.VerticalAlignment = xlCenter
End With
'zusammenführung der einzelübersicht
Dim ez As Long, lz As Long, ez2 As Long
ez = 6  'überschrift steht in zeile 6
lz = Cells(ez, 1).End(xlDown).Row
ez2 = lz + 1
Range("A" & ez & ":" & "A" & lz).AdvancedFilter Action:=xlFilterCopy, copytorange:=Range("A" &  _
_
ez2), _
Unique:=True
Range("A" & ez2 & ":" & "A" & Cells(ez2, 1).End(xlDown).Row).Sort Key1:=Cells(ez2, 1), _
Order1:=xlAscending, Header:=xlYes
Cells(ez2, 1).Delete shift:=xlUp
End Sub

ich hab mal geguckt aber nicht herrausfinden können, woran es liegt. ;-((
danke für deine unterstützung.
gruss kirsche

Beliebteste Forumthreads (12 Monate)

	A
1	Daten
2	92
3	40
4	46
5	13
6	27
7	37
8	72
9	14
10	16
11	16
12	19
13	46
14	22
15	21
16	60
17	80
18	87
19	58
20	87

19 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

19
Beiträge zum Forumthread

Beiträge zu diesem Forumthread