Microsoft Excel

Herbers Excel/VBA-Archiv

Formel gesucht | Herbers Excel-Forum


Betrifft: Formel gesucht von: Karin
Geschrieben am: 12.01.2010 10:47:23

Hallo zusammen,
ich schreibe heute meinen ersten Beitrag in dieses Forum.
Ich hoffe das ich das Problem für euch verständlich erklären kann.
Ich habe eine Datei mit Bestellungen von Lieferanten.
In dieser Datei kommen die Bestell-Nr. und die Bestell-Pos. mehrfach vor.
Sie unterscheiden sich nur durch das Bestell-Datum und die Bestell-Menge.
Ich möchte gerne erreichen, dass mir pro Bestell-Nr. die Zeile mit der höchsten Pos.-Nr.
aufgelistet wird.
Dabei soll das Datum , die Bestell-Nr., die Bestell-Pos, die Mengeneinheit , der Lieferant
und die Gesamtmenge der höchsten Position erscheinen.
Alle anderen Positionen können gelöscht werden oder brauchen nicht mehr sichtbar sein.
(siehe Beispiel)
Ich hoffe das Problem ist einigermaßen verständlich dargestellt.
Hat jemand von euch eine Idee?

Freundliche Grüße

Karin


  

Betrifft: AW: Formel gesucht von: Rudi Maintaire
Geschrieben am: 12.01.2010 11:03:42

Hallo,
1. per Spezialfilter ohne Duplikate eine Liste aller Best-Nr erstellen.
2. die höchste Pos. per Matrixformel: {=MAX(($B$5:$B$21=B28)*$C$5:$C$21)}
3. die Summen: =SUMMENPRODUKT((B$5:B$21=B28)*(C$5:C$21=C28)*D$5:D$21)

Matrixformel: {} nicht eingeben, sondern Formel mit shift+strg+enter abschließen.

Gruß
Rudi


  

Betrifft: AW: Formel gesucht von: Karin
Geschrieben am: 12.01.2010 13:16:55

Hallo Rudi,
vielen Dank für die schnelle Antwort.
Ich werde es gleich mal ausprobieren.

Liebe Grüße
Karin


  

Betrifft: AW: Formel gesucht von: Josef Ehrensberger
Geschrieben am: 12.01.2010 12:06:19

Hallo Karin,

hier eine VBA lösung.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub listMax()
  Dim rng As Range, rngDel As Range
  Dim lngRow As Long, lngLast As Long
  
  On Error GoTo ErrExit
  Application.ScreenUpdating = False
  
  lngRow = 5 'erste Datenzeile
  
  lngLast = Application.Max(lngRow, Cells(Rows.Count, 1).End(xlUp).Row) 'letzte Datenzeile
  
  Columns(8).Insert
  Cells(lngRow, 8).FormulaArray = "=IF((C" & lngRow & "=MAX(IF($B$" & lngRow & _
    ":$B$" & lngLast & "=B" & lngRow & ",$C$" & lngRow & ":$C$" & lngLast & "))),C" _
    & lngRow & ","""")"
  Range(Cells(lngRow, 8), Cells(lngLast, 8)).FillDown
  
  Columns(9).Insert
  Cells(lngRow, 9).FormulaArray = "=IF(H" & lngRow & "="""","""",IF(A" & lngRow & _
    "=MAX(IF($C$" & lngRow & ":$C$" & lngLast & "=H" & lngRow & ",$A$" & lngRow & _
    ":$A$" & lngLast & ")),A" & lngRow & ",""""))"
  Range(Cells(lngRow, 9), Cells(lngLast, 9)).FillDown
  
  Columns(10).Insert
  Cells(lngRow, 10).Formula = "=IF(AND(H" & lngRow & "<>"""",I" & lngRow & _
    "<>""""),SUMIF($H$" & lngRow & ":$H$" & lngLast & ",H" & lngRow & ",$D$" & _
    lngRow & ":$D$" & lngLast & "),"""")"
  Range(Cells(lngRow, 10), Cells(lngLast, 10)).FillDown
  
  For Each rng In Range("J" & lngRow & ":J" & lngLast)
    If rng <> "" Then
      rng.Offset(0, -6) = rng.Value
    Else
      If rngDel Is Nothing Then
        Set rngDel = rng.EntireRow
      Else
        Set rngDel = Union(rngDel, rng.EntireRow)
      End If
    End If
  Next
  
  If Not rngDel Is Nothing Then rngDel.Delete
  
  Union(Columns(8), Columns(9), Columns(10)).Delete
  
  ErrExit:
  Application.ScreenUpdating = True
  Set rng = Nothing
  Set rngDel = Nothing
End Sub



Gruß Sepp



  

Betrifft: AW: Formel gesucht von: Karin
Geschrieben am: 12.01.2010 13:58:27

Hallo Josef,
vielen Dank für deine Antwort.
Ich bin begeistert was man mit VBA alles machen kann,-
vorausgesetzt man kennt sich da aus.,- so wie du.
Ich bin da vollkommen überfragt.
Ich hätte da noch mal eine Frage.
Das Makro läuft ja sauber durch.
Meine Liste die ich auszuwerten habe, besteht aus ca. 2000 Positionen
mit ca. 1400 unterschiedlichen Lieferanten.
Dann funktioniert das Makro aber nicht mehr, oder?
Kannst du das noch erweitern?
Oder ist das zuviel Arbeit?

Liebe Grüße
Karin


  

Betrifft: AW: Formel gesucht von: Josef Ehrensberger
Geschrieben am: 12.01.2010 14:04:14

Hallo Karin,

doch, das Makro fuktioniert auch bei deiner Liste, vorausgesetzt der Aufbau ist derselbe.


Gruß Sepp



  

Betrifft: AW: Formel gesucht von: Karin
Geschrieben am: 13.01.2010 10:49:02

Hallo Josef,
ich habe das ganze heute morgen noch mal durchgespielt,
und zwar habe ich die vorhandene Datei um 2 Sätze erweitert.
Ich habe den letzten Satz kopiert und einfach hinten 2 x angefügt.
In diesen beiden Sätzen habe ich dann nur die Bestell-Nr. geändert.
Das Makro hat aber die Änderung nicht verarbeitet.
Kannst du dir das erklären, oder mache ich was falsch?

Gruß
Karin


https://www.herber.de/bbs/user/67185.doc

https://www.herber.de/bbs/user/67186.xls


  

Betrifft: AW: Formel gesucht von: Josef Ehrensberger
Geschrieben am: 13.01.2010 11:51:49

Hallo Karin,

hab den Code nochmal überarbeitet.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit


Sub listMax()
  Dim rng As Range, rngDel As Range
  Dim lngRow As Long, lngLast As Long
  
  On Error GoTo ErrExit
  Application.ScreenUpdating = False
  
  lngRow = 5 'erste Datenzeile
  
  lngLast = Application.Max(lngRow, Cells(Rows.Count, 1).End(xlUp).Row) 'letzte Datenzeile
  
  Columns(8).Insert
  Cells(lngRow, 8).FormulaArray = "=IF((C" & lngRow & "=MAX(IF($B$" & lngRow & _
    ":$B$" & lngLast & "=B" & lngRow & ",$C$" & lngRow & ":$C$" & lngLast & _
    "))),C" & lngRow & ","""")"
  Range(Cells(lngRow, 8), Cells(lngLast, 8)).FillDown
  
  Columns(9).Insert
  Cells(lngRow, 9).FormulaArray = "=IF(H" & lngRow & "="""","""",IF(A" & lngRow _
    & "=MAX(IF(($B$" & lngRow & ":$B$" & lngLast & "=B" & lngRow & ")*($C$" & _
    lngRow & ":$C$" & lngLast & "=H" & lngRow & "),$A$" & lngRow & ":$A$" & _
    lngLast & ")),A" & lngRow & ",""""))"
  Range(Cells(lngRow, 9), Cells(lngLast, 9)).FillDown
  
  Columns(10).Insert
  Cells(lngRow, 10).Formula = "=IF(AND(H" & lngRow & "<>"""",I" & lngRow & _
    "<>""""),SUMPRODUCT(($B$" & lngRow & ":$B$" & lngLast & "=B" & lngRow & _
    ")*($H$" & lngRow & ":$H$" & lngLast & "=H" & lngRow & ")*$D$" & lngRow & _
    ":$D$" & lngLast & "),"""")"
  Range(Cells(lngRow, 10), Cells(lngLast, 10)).FillDown
  
  For Each rng In Range("J" & lngRow & ":J" & lngLast)
    If rng <> "" Then
      rng.Offset(0, -6) = rng.Value
    Else
      If rngDel Is Nothing Then
        Set rngDel = rng.EntireRow
      Else
        Set rngDel = Union(rngDel, rng.EntireRow)
      End If
    End If
  Next
  
  If Not rngDel Is Nothing Then rngDel.Delete
  
  Union(Columns(8), Columns(9), Columns(10)).Delete
  
  ErrExit:
  Application.ScreenUpdating = True
  Set rng = Nothing
  Set rngDel = Nothing
End Sub



Gruß Sepp



  

Betrifft: AW: Formel gesucht von: Karin
Geschrieben am: 14.01.2010 10:37:19

Hallo Josef,
ich komme leider erst jetzt dazu dein überarbeitetes VBA zu prüfen.
Es funktioniert super, vielen vielen Dank.
Bis zum nächsten Mal.

Lieber Grüße
Karin


  

Betrifft: AW: Formel gesucht von: welga
Geschrieben am: 13.01.2010 11:56:58

Hallo Karin,

mach dir mal eine Kopie deiner Tabelle und versuche den folgenden Code:

Sub auflistung()
Dim i As Long
Dim a As Long
Dim tabelle As Range
    Set tabelle = Range(Cells(4, 1), Cells(Cells(4, 1).End(xlDown).Row, 4))
    Range("A4:F4").Select
    Selection.AutoFilter
    Range("a1").Select
    tabelle.Sort Key1:=Range("C4"), Order1:=xlDescending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    tabelle.Sort Key1:=Range("B4"), Order1:=xlDescending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
        a = Cells(4, 1).End(xlDown).Row
        For i = a To 5 Step -1
            If Cells(i, 2) = Cells(i - 1, 2) Then
            Rows(i).Delete Shift:=xlUp
            'i = i + 1
            End If
        Next i
    Set tabelle = Range(Cells(4, 1), Cells(Cells(4, 1).End(xlDown).Row, 4))
    tabelle.Sort Key1:=Range("A4"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("A4:F4").Select
    Selection.AutoFilter
    Range("A1").Select
End Sub
Aber vorsicht, dieser löscht dir alle Zeilen die du nicht haben willst.

Gruß
welga


  

Betrifft: @ Welga, und wo sind die summierten Werte? o.T. von: Josef Ehrensberger
Geschrieben am: 13.01.2010 12:00:39

Gruß Sepp



  

Betrifft: jetzt inkl. summierter Werte von: welga
Geschrieben am: 13.01.2010 12:19:18

Hallo,

ich hatte das ganz übersehen. Deshalb nun noch einmal:

Sub auflistung()
 Dim i As Long
 Dim ii As Long
 Dim a As Integer
 Dim tabelle As Range
     Set tabelle = Range(Cells(4, 1), Cells(Cells(4, 1).End(xlDown).Row, 4))
     Range("A4:F4").Select
     Selection.AutoFilter
     Range("a1").Select
     tabelle.Sort Key1:=Range("C4"), Order1:=xlDescending, Header:= _
         xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
         DataOption1:=xlSortNormal
     tabelle.Sort Key1:=Range("B4"), Order1:=xlDescending, Header:= _
         xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
         DataOption1:=xlSortNormal
         ii = Cells(4, 1).End(xlDown).Row
         For i = ii To 5 Step -1
            a = 0
              If Cells(i, 2) = Cells(i - 1, 2) Then
                    If Cells(i, 3) = Cells(i - 1, 3) Then
                        a = Cells(i, 4).Value + Cells(i - 1, 4).Value
                        Cells(i - 1, 4).Value = a
                    End If
              Rows(i).Delete Shift:=xlUp
              End If
         Next i
     Set tabelle = Range(Cells(4, 1), Cells(Cells(4, 1).End(xlDown).Row, 4))
     tabelle.Sort Key1:=Range("A4"), Order1:=xlAscending, Header:= _
         xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
         DataOption1:=xlSortNormal
     Range("A4:F4").Select
     Selection.AutoFilter
     Range("A1").Select
 End Sub

Gruß
welga


  

Betrifft: AW: jetzt inkl. summierter Werte von: Karin
Geschrieben am: 14.01.2010 10:45:27

Hallo welga,
vielen Dank für die schnelle Antwort. Leider konnte ich dein VBA erste jetzt testen.
Bei mir kommt folgender Fehlermeldug hoch:
(siehe Anlage)

Gruß
Karin




  

Betrifft: AW: jetzt inkl. summierter Werte von: Hajo_Zi
Geschrieben am: 14.01.2010 10:46:40

Hallo KArin,

lösche den Teil DataOption, den gibt es in Deiner Vesion noch nicht.

GrußformelHomepage


  

Betrifft: AW: jetzt inkl. summierter Werte von: Karin
Geschrieben am: 14.01.2010 12:48:35

Hallo Hajo,
vielen Dank, es hat geklappt.
Super !
Bis zum nächsten Mal.

Liebe Grüße
Karin


Beiträge aus den Excel-Beispielen zum Thema "Formel gesucht"