VBA Berechnungslösung

Hallo zusammen,
hier mal ein beispiel meines Problems:
Spalte A Spalte B Spalte C Spalte D Spalte E Spalte F
Lgr------Halle-----------Tor--------Markt------BSF------Volumen
100--------2-------------151--------3000-------1513------600
100--------2-------------151--------3000-------1513------1500
100--------2-------------151--------3000-------1513------1400
100--------3-------------252--------2520-------2512-------300
100--------3-------------252--------2520-------2512-------500
100--------5-------------253--------1350-------2531-------1400
100--------5-------------253--------1350-------2531-------1200
usw...
Jetzt soll über VBA von Spalte B-E gleiche Werte ermittelt werden (Duplikate). Wenn es welche gibt dann soll in Spalte F addiert werden. Das Ergebnis soll nur dann in Tabelle 2 geschrieben werden wenn die Berechnung der Spalte F unter oder Maximal bis 1600 ergibt.
Es sind immer andere Werte keine festen Werte. Hier Wäre doch auch eine Schleife sinvoll oder ?
hier das Beispiel.
in dem Fall Markt 2520
Volumen
300+
500
=800
Tabelle 2
Halle-------Tor---------Markt------BSF----Ergebnis
3-----------252---------2520-------2512------X
Da hier das Volumen noch unter dem Maximalwert von 1600 liegt

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Robert,
Ich hab mich mal dran versucht...

' **********************************************************************
' Modul: Tabelle1  Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Sub machs()
    Dim arr As Variant
    Dim L As Long
    Dim I As Integer
    Dim myDic As Object
    Dim Element
    Dim lngRow As Long
    With Sheets("Tabelle1").Range("A1")
        arr = Intersect(.CurrentRegion, .CurrentRegion.Offset(1, 0))
    End With
    Set myDic = CreateObject("scripting.Dictionary")
    For L = LBound(arr) To UBound(arr)
        'Jetzt soll über VBA von Spalte B-E gleiche Werte ermittelt werden (Duplikate).
        'Wenn es welche gibt dann soll in Spalte F addiert werden.
        myDic(arr(L, 2) & "_" & arr(L, 3) & "_" & arr(L, 4) & "_" & arr(L, 5)) = myDic(arr(L, 2) & "_" & arr(L, 3) & "_" & arr(L, 4) & "_" & arr(L, 5)) + arr(L, 6)
    Next
    For Each Element In myDic.keys
        If myDic(Element) <= 1600 Then '..wenn die Berechnung der Spalte F unter oder Maximal bis 1600 ergibt.
            With Sheets("Tabelle2")
                lngRow = lngRow + 1
                .Cells(lngRow, 1).Resize(, 4) = Split(Element, "_") 'Das Ergebnis soll nur dann in Tabelle 2 geschrieben werden
                .Cells(lngRow, 5) = myDic(Element)
            End With
        End If
    Next
End Sub



ransi

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread