'opschonen data
'Call Correct_Cells
' Collect spare parts form sheets
Dim sh As Worksheet, sn, i As Integer, sModule As String, sPlaats As String, Dict As Object, sArt As String, Arr(1 To 1, 1 To 6), it, c As Range, j As Integer
Set Dict = CreateObject("scripting.dictionary")
With Dict 'je dictionary definieren
.comparemode = 1 'geen onderscheid hoofdletters/kleine letters
For Each sh In Worksheets 'alle werkbladen aflopen
Select Case sh.Name
Case "Report", "Report_History", "POI" 'deze 2 bladen niet
Case Else 'alle andere
sn = sh.Range("A1").CurrentRegion.Resize(, 12).Value 'bereik rond A1 van dat blad 12 kolommen breed inlezen naar een array
sModule = "???": sPlaats = "???" 'naam van de module resetten
For i = 3 To UBound(sn) 'alle rijen van je array aflopen te beginnen vanaf de 2e
If sn(i, 1) = ".2" Then sModule = sn(i, 5): sPlaats = sn(i, 2) 'een nieuwe module begint met een ".2" in de 1e kolom, dus die naam onthouden voor straks
If sn(i, 12) > 0 Then 'een aantal gewenst
sArt = "|" & sPlaats & "|" & sModule & "|" 'een uniek record is plaats + modulenaam + artikelcode
it = .Item(sArt) 'kijken op dat record in de dictionary
Select Case VarType(it) 'wat weet je over dat record
Case vbEmpty 'zat nog niet in de dictionary, dus even snel zelf een array met de nodige gegevens aanmaken
Arr(1, 1) = sArt '1e element = je unieke sleutel
Arr(1, 2) = sn(i, 4) '2e element = je artikelcode
Arr(1, 3) = sn(i, 5) '3e element = je omschrijving
Arr(1, 4) = sn(i, 12) & " " '4e element = het aantal
Arr(1, 5) = sn(i, 10) '5e element = eenheid
.Item(sArt) = Arr 'array naar dictionary schrijven
Case Else:
it(1, 2) = it(1, 2) & vbLf & sn(i, 4)
it(1, 3) = it(1, 3) & vbLf & sn(i, 5)
it(1, 4) = it(1, 4) & vbLf & sn(i, 12)
it(1, 5) = it(1, 5) & vbLf & sn(i, 10)
.Item(sArt) = it 'bestond wel al, dus enkel aantal cumuleren in je array en terug naar dictionary schrijven
End Select
End If
Next
End Select
Next
End With
LastRow = ActiveSheet.Range("C65000").End(xlUp).Row
With Range("E3:E" & LastRow)
' .Offset(, 5).Resize(, 4).ClearContents
For Each c In .Cells 'alle modules aflopen
If c.Offset(, -2).Value <> "" And c.Value <> "" Then 'plaats en module niet leeg
sArt = "|" & c.Offset(, -2).Value & "|" & c.Value & "|"
it = Dict.Item(sArt) 'opvragen in de dictionary van de unieke sleutel (plaats + module)
If Not VarType(it) = vbEmpty Then c.Offset(, 5).Resize(, 4).Value = Array(it(1, 2), it(1, 3), it(1, 4), it(1, 5)) 'stond die al in de dictionary dan gegevens wegschrijven
Dict.Remove sArt 'record verwijderen
End If
Next
.EntireRow.AutoFit
End With
MsgBox ("Amount of Faults: " & Dict.count)
If Dict.count Then MsgBox "These modules are not in the report" & vbLf & Join(Dict.keys, vbLf), vbCritical 'zaken die niet weggeschreven konden
