AW: Doppeleinträge namen ändern
25.05.2018 01:14:49
Barbaraa
Hallo
pass mal du gut auf.
Diese beiden Makros in ein Modul:
Sub ArbeitsplatzSumme()
Dim sArtikel As String 'Artikelnummer
Dim sArbPl As String 'Arbeitsplatz
Dim i As Long, j As Long 'Zeilenposition
'Ergebnisliste (Arbeitsplätze und Zeit)
Dim rListenende As Range 'Letzte Zelle
Dim rListenende1 As Range 'Letzte Zelle
Dim k As Long 'Aktuelle Zeile Ergebnisliste
'Liste
Dim lAnfang As Long 'Erste Zeile der Liste
Dim lSchluss As Long 'Letzte Zeile der Liste
'Spaltennummern
Dim lAP As Long 'Spaltennummer Arbeitplatz
Dim lArt As Long 'Spaltennummer Artikelnummer
Dim lZeit As Long 'Spaltennummer Zeit
Dim lZEh As Long 'Spaltennummer Zeiteinheit
Dim lHS As Long 'Spaltennummer Hilfsspalte
Dim LAPL As Long 'Spaltennummer Artikelliste
Dim sSekArbPl1 As String 'sekundärer Arbeitsplatz 1
Dim sSekArbPl2 As String 'sekundärer Arbeitsplatz 2
sSekArbPl1 = 11042000 'sekundärer Arbeitsplatz 1
sSekArbPl2 = 11036000 'sekundärer Arbeitsplatz 2
lAP = 1 'Spaltennummer Arbeitplatz
lArt = 4 'Spaltennummer Artikelnummer
lZeit = 5 'Spaltennummer Zeit
lZEh = 6 'Spaltennummer Zeiteinheit
lHS = 7 'Spaltennummer Hilfsspalte
LAPL = 9 'Spaltennummer Artikelliste
lAnfang = 3
With ActiveSheet
lSchluss = .Cells(Rows.Count, lAP).End(xlUp).Row
'Hilfstabelle anlegen
Range(Cells(lAnfang, lZeit), Cells(lSchluss, lZeit)).Copy Range(Cells(lAnfang, lHS), _
Cells(lSchluss, lHS))
'Ergebnistabelle anlegen
Set rListenende = Cells(lAnfang, LAPL)
rListenende.Value = "Prim. AP"
rListenende.Offset(0, 1).Value = "Zeit"
rListenende.Offset(0, 2).Value = "Einheit"
'Zeile für Zeile durchgehen
For i = lAnfang To lSchluss
If .Cells(i, lAP).Value sSekArbPl1 And _
.Cells(i, lAP).Value sSekArbPl2 And _
.Cells(i, lHS).Value "" And _
.Cells(i, lArt).Value "" Then
' .Cells(i, lArt).Select
sArbPl = .Cells(i, lAP).Value
'Ergebnisliste auf pAP prüfen
k = rListenende.Row
Set rListenende = Range(.Cells(lAnfang, LAPL), rListenende).Find(sArbPl, LookIn: _
=xlValues, LookAt:=xlWhole)
If rListenende Is Nothing Then
'Neuer AP in Ergebnisliste anlegen
k = k + 1
Set rListenende = .Cells(k, LAPL)
rListenende.Select
With rListenende
Range(rListenende, .Offset(0, 2)).NumberFormat = "General"
.Value = sArbPl
.Offset(0, 1).Value = 0
.Offset(0, 2).Value = "H"
End With
Else
' Set rListenende = rListenende1
End If
' .Cells(i, lArt).Select
sArtikel = .Cells(i, lArt).Text
For j = i To lSchluss
If .Cells(j, lHS).Value "" And .Cells(j, lArt).Text = sArtikel Then
.Cells(k, LAPL + 1).Value = .Cells(k, LAPL + 1).Value + ZeitInStunden(. _
Cells(j, lZeit).Value, .Cells(j, lZEh).Text)
.Cells(j, lHS).Value = ""
End If
Next j
End If
Next i
End With
End Sub
Function ZeitInStunden(dWert As Double, sEinheit As String) As Double
Select Case sEinheit
Case Is = "H"
ZeitInStunden = dWert
Case Is = "MS"
ZeitInStunden = dWert / 1000 / 3600
Case Is = "MIN"
ZeitInStunden = dWert / 60
Case Else
MsgBox "Einheit " & sEinheit & " wird ignoriert!"
ZeitInStunden = 0
End Select
End Function
Laufzeit ca. 10 Sekunden
Wenn Du die .select-Zeilen aktivierst, siehst Du mehr, dauert aber ein paar Minuten.
Zeiten:
Alles in Stunden.
1 H = 60 MIN = 3,6 Mio. MS. Andere Zeiteinheiten werden nicht gezählt (LH).
Achtung: Auch negative Zeiten kommen vor.
Zuordnung:
Habe keine Zeitstempel beachtet. Jeder Artikel wird dem in der Liste ersten prim. AP zugeordnet.
Artikel, die nur in sek. AP vorkommen, werden nicht summiert. Daher ergeben sich Unterschiede zu Deinem Ergebnis.
Hoffe, es funktioniert gut. Viel Spass.
Bei Fragen bitte fragen.
LGB
