Summieren mit Unterbrechung

Guten Tag,
anhand folgender Beispieldatei möchte ich gerne mein Problem schildern:
https://www.herber.de/bbs/user/133871.xlsx
Und zwar möchte ich gerne die Rüstvorgänge eines Werkzeuges erfassen.
Tabelle 1 wird täglich fortgeführt und das Ergebnis (Anzahl Rüstvorgänge eines Werkzeuges) sollen in Tabelle 2 ausgegeben werden.
Problem dabei ist, dass jede Schicht die aktuelle Maschinenbelegung dokumentiert. Als Beispiel kann man das Werkzeug 629 nennen. Es wurde in der Tabelle 6x erwähnt, dennoch war es nur ein Rüstvorgang. Danach lief das Werkzeug 999 auf der Maschine.
Sollte das Werkzeug 629 im weiteren zeitlichen Verlauf wieder auf der Maschine 237 laufen, soll dies als 2. Rüstvorgang gewertet werden.
Es kann durchaus vorkommen das ein Werkzeug mal auf der 238 lief, dann mal auf der 237. Mir würde es aber genügen wenn man die Maschinen einzeln betrachtet und die Rüstvorgänge des Werkzeuges auf den verschiedenen Maschinen summiert.
Ich hoffe ich habe mein Problem verständlich geschildert.
Gruß&Danke

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Epstein,
ich schlage für dein Problem die folgende VBA-Lösung vor:

Sub Verarbeitung()
Dim arr As Variant
Dim dic As Object
Dim i As Long
Dim letzteZeileH As Long
Dim letzteZeileR As Long
Dim sortBereich As Range
Dim wb As Workbook
Dim werkzeug As Long
Dim wsH As Worksheet
Dim wsR As Worksheet
Dim wsT1 As Worksheet
Dim zeileH As Long
Dim zeileR As Long
Set wb = ThisWorkbook
Set wsH = wb.Worksheets("Hilfsblatt")
wsH.UsedRange.ClearContents
Set wsT1 = wb.Worksheets("Tabelle1")
letzteZeileH = wsT1.Cells(wsT1.Rows.Count, "A").End(xlUp).Row
If letzteZeileH = 1 Then
MsgBox "Keine Daten"
Exit Sub
End If
wsT1.Range("A1").Resize(letzteZeileH, 4).Copy Destination:=wsH.Range("A1")
For zeileH = 2 To letzteZeileH
wsH.Cells(zeileH, "D") = zeileH - 1
Next zeileH
Set sortBereich = wsH.Range("A1").Resize(letzteZeileH, 4)
With wsH.Sort
With .SortFields
.Clear
.Add Key:=wsH.Range("B2")
.Add Key:=wsH.Range("A2")
.Add Key:=wsH.Range("D2")
End With
.SetRange Rng:=sortBereich
.Header = xlYes
.Apply
End With
Set wsR = wb.Worksheets("Rüstvorgänge")
letzteZeileR = wsR.Cells(wsR.Rows.Count, "A").End(xlUp).Row
If letzteZeileR > 1 Then
wsR.Range("A2").Resize(letzteZeileR - 1, 4).ClearContents
End If
Set dic = CreateObject("Scripting.Dictionary")
zeileR = 2
For zeileH = 2 To letzteZeileH
werkzeug = wsH.Cells(zeileH, "C")
If werkzeug  wsH.Cells(zeileH + 1, "C") And _
wsH.Cells(zeileH, "B") = wsH.Cells(zeileH + 1, "B") Then
' Es liegt ein Rüstvorgang vor
If dic.Exists(Key:=werkzeug) Then
dic.Item(werkzeug) = dic.Item(werkzeug) + 1
Else
dic.Add Key:=werkzeug, _
Item:=1
End If
End If
Next zeileH
arr = dic.Keys
For i = LBound(arr) To UBound(arr)
wsR.Cells(i + 2, "A") = arr(i)
wsR.Cells(i + 2, "B") = dic.Item(arr(i))
Next i
letzteZeileR = i + 1
Set dic = Nothing
Set sortBereich = wsR.Range("A1").Resize(letzteZeileR, 2)
With wsR.Sort
With .SortFields
.Clear
.Add Key:=wsR.Range("A2")
End With
.SetRange Rng:=sortBereich
.Header = xlYes
.Apply
End With
wsR.Activate
wsR.Range("A1").Activate
End Sub

Das Programm benötigt ein Hilfsblatt, welches du auch ausblenden kannst, falls es die Optik stört.
https://www.herber.de/bbs/user/133968.xlsm
Viele Grüße und noch schöne Feiertage
Dieter

Beliebteste Forumthreads (12 Monate)

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread