Voorraden op 2 vestigingen alleen zien

[ronaldvm1964]

Zie bijlage,

In het 1ste werkblad staan artikelen met daarvoor de vesting SBG of WDX.
Nu zou ik willen dat artikelen waar zowel de vesting SBG en WDX staan, deze apart in het 2e werkblad komen staan, geen artikelen die alleen in SBG voor kan komen.
Vestiging WDX moet een andere kleur krijgen (blauw bijv) en de artikelen moeten in volgorde staan van tht.

We zijn over gegaan naar het nieuwe system en daardoor werkte het oude bestand niet meer, er zitten wel macro's in maar deze werken niet meer goed.

Misschien dat iemand mij kan helpen.

Gr,
Ronald

 

[AlexCEL]

Zoiets als in bijlage?

Let op: matrixfuncties, d.w.z. afsluiten met Control+Shift+Enter.

Voor grote datasets kan het wel traag worden...

 

[ronaldvm1964]

Dit ziet er al goed uit, maar kan zoiets ook in een macro als het mogelijk is.

 

[Piet Bom]

Hierbij een poging met een macro.
Ik weet dat de code korter kan en ook sneller, maar dat kan je later nog verbeteren als het te traag mocht gaan.

 

[ronaldvm1964]

Als ik nieuwe data in wil zetten en ik draai de macro, dan krijg ik een foutmelding.

op onderstaande regel:
art = CLng(arr1(i, 2)) ' "a" & Format(arr1(i, 2), "00000")

Is er ook nog een mogelijkheid om de regel WDX een kleurtje te geven bijvoorbeeld blauw.

 

[Piet Bom]

Ik heb inmiddels een nieuwe versie, die iets stabieler zou moeten zijn.
Kun je de live data kopiëren in deze versie ?
Dan weten we of het aan de data ligt of aan de oorspronkelijke file-structuur.
Macro's kunnen heel bot zijn en bepaalde bereiken leegmaken, wat je misschien liever niet wilt.
Het is belangrijk dat de data in kolom artikel van het formaat is: 00123 , dus 5 posities en alleen cijfers van 0 tot 9
Je zou ook een representatief deel van jouw origineel laten zien en dan bijvoorbeeld het middenstuk weglaten, zodat we het begin en het eind kunnen zien.
Affijn, probeer deze bijlage eens.

 

[VenA]

Ik had deze gisteren gemaakt maar blijkbaar niet geplaatst.
Volledig met een macro al krijg ik andere resultaten dan @AlexCEL in #2

Sub VenA()
  Application.ScreenUpdating = False
  Dim j As Long, jj As Long, c00 As String, ar
  ar = Sheets("Verhuizing").Cells(1).CurrentRegion
  c00 = " 1"
  For j = 2 To UBound(ar)
    For jj = 2 To UBound(ar)
      If ar(j, 2) = ar(jj, 2) And ar(j, 1) <> ar(jj, 1) Then
        c00 = c00 & " " & j
        Exit For
      End If
    Next jj
  Next j
  y = Application.Index(ar, Application.Transpose(Split(Mid(c00, 2))), Application.Transpose([row(1:8)]))
  With Sheets("Verhuizing 1")
    .UsedRange.Clear
    .Cells(1).Resize(UBound(y), 8) = y
    With .Cells(1).CurrentRegion
      .Sort .Cells(1, 7), , , , , , , xlYes
      .AutoFilter 1, "WDX"
      .Offset(1).Columns(1).SpecialCells(2).Interior.Color = vbBlue
      .AutoFilter 1
    End With
  End With
End Sub

 

[ronaldvm1964]

Ik heb inmiddels een nieuwe versie, die iets stabieler zou moeten zijn.
Kun je de live data kopiëren in deze versie ?
Dan weten we of het aan de data ligt of aan de oorspronkelijke file-structuur.
Macro's kunnen heel bot zijn en bepaalde bereiken leegmaken, wat je misschien liever niet wilt.
Het is belangrijk dat de data in kolom artikel van het formaat is: 00123 , dus 5 posities en alleen cijfers van 0 tot 9
Je zou ook een representatief deel van jouw origineel laten zien en dan bijvoorbeeld het middenstuk weglaten, zodat we het begin en het eind kunnen zien.
Affijn, probeer deze bijlage eens.

Deze werkt perfect, toch knap hoe het gemaakt is, ik zou er niet uitgekomen zijn.
mocht het artikelnummer nu meer cijfers zijn wat moet er dan precise aangepast worden.

 

[Piet Bom]

Format(….,"00000") wordt dan Format(….,"000000") en dat 5 keer (met Replace functie)

 

[ronaldvm1964]

Duidelijk, ik had het volgende eigenlijk gelijk moeten vragen.
Als er meer dan 2 vestigingen

If st = "SBG" Then tel1 = tel1 + 1
If st = "WDX" Then tel2 = tel2 + 1

moet ik dan het volgende toevoegen
If st = "HFT" Then tel2 = tel3 + 1

Ik kan alleen de kleur niet zo gauw vinden.

ALs ik dit weet ben ik zeer geholpen

 

[Piet Bom]

moet ik dan het volgende toevoegen
If st = "HFT" Then tel2 = tel3 + 1

Ik kan alleen de kleur niet zo gauw vinden.

Bijna goed: If st = "HFT" Then tel3 = tel3 + 1
En verder nog een stuk of 20 aanpassingen.
Eerst was de voorwaarde dat de artikelen op minstens 2 locaties moesten liggen.
Ik neem aan dat ze op minstens op 3 locaties moeten liggen.
Dus op: SBG en WDX en HFT
Of is de voorwaarde op minstens op 2 van de 3 locaties ?
Dus op: (SBG en WXD) of (SBG en HFT) of (WDX en HFT)

Ik heb een mooie kleur kunnen vinden

Zie de bijlage...………...

 

[Piet Bom]

Voor het tweede geval hoef je alleen maar de volgende aanpassing te doen:

If tel1 > 0 And tel2 > 0 And tel3 > 0 Then

If (tel1 > 0 And tel2 > 0) Or (tel1 > 0 And tel3 > 0) Or (tel2 > 0 And tel3 > 0) Then

 

[ronaldvm1964]

SBG, WDX en HFT is goed, het worden er nooit meer dan 3.
Werkt goed, hier kan ik mee vooruit.

Dank je wel :thumb:

 

[Piet Bom]

Graag gedaan.
Toch nog wat vragen: is dit eenmalig zo'n verhuizing of gaat de code later nog vaker gebruikt worden ?
Indien eenmalig, zou een quick and dirty formule sneller zijn dan een macrootje programmeren (dat is minder quick ).
En wat is de reden om alleen artikelen te filteren als ze op beide locaties liggen ?
Het was wat mij betreft weer leerzaam, ik hoop voor jou ook.

 

[ronaldvm1964]

We gaan over op een system en de oude wat gebouwd was gaat niet meer werken.
Dit zal een lange tijd gebruikt gaan worden.

Het moet gebruikt kunnen worden voor elke vestiging.
Dus vestiging ZTM, HFT2 en HFT3 zou er ook bij moeten, is dit moeilijk aan te passen of makkelijk.

De reden om alleen de artikelen de filteren als ze op 2 of meer vestigingen liggen is om een beter overzicht te hebben welke artikelen buiten de deur staan.

Kolom F is nog leeg, hier ben ik nog mee bezig om goeie lijst uit het system te krijgen (dit is de kolom van de reserveringen)

Bij verhuizing(pcb)5 doet de macro het wel met de nieuwe gegevens en bij (pcb)6 niet, komt dat er geen HFT instaat?

 

[Piet Bom]

De code aanpassen kost wat meer tijd. Ik zal komend weekend even proberen.
Maar je kunt ook voor de handmatige methode gaan:
1. Maak een draaitabel zie blad: Pivot1
2. Voeg daar wat formules bij (blauwe tekst)
3. Ga naar blad Verhuizing en voeg daar 1 kolom met VLOOKUP-formules toe (blauwe tekst)
4. Met de AutoFilter op die kolom kun je alle Yes filteren
5. Met knippen en plakken kun je de gefilterde regels overzetten naar blad Verhuizing1
Je moet altijd praktisch blijven denken. Programmeren duurt 2 uur. De handmatige methode duurt 10 minuten.
Als je dit kunstje meer dan 12 keer ga doen, gaat de code winst opleveren.

 

[Piet Bom]

Toch weer een uurtje of 2 zitten programmeren
Deze laatste versie is nu geschikt voor meerdere opslaglocaties (flexibel, maar nog niet getest)
Ik ben benieuwd wat voor een systeem jullie gaan krijgen om deze vraag op te lossen.

 

[VenA]

Als sneller alternatief. De uitkomsten even op andere tabjes om het geheel te kunnen vergelijken. In de code heb ik geen rekening gehouden met de kleinste datum. In sheet1 de tabel in sheet2 de samenvatting.

Sub VenA()
  Application.ScreenUpdating = False
  Dim j As Long, jj As Long, c00 As String, ar, y, ar1(7), d
  ar = Sheets("Verhuizing").Cells(1).CurrentRegion
  c00 = " 1"
  For j = 2 To UBound(ar)
    For jj = 2 To UBound(ar)
      If ar(j, 2) = ar(jj, 2) And ar(j, 1) <> ar(jj, 1) Then
        c00 = c00 & " " & j
        Exit For
      End If
    Next jj
  Next j
  
  y = Application.Index(ar, Application.Transpose(Split(Mid(c00, 2))), Application.Transpose([row(1:8)]))
  Set d = CreateObject("Scripting.Dictionary")
  For j = 2 To UBound(y)
    y(j, 7) = Format(y(j, 7), "mm-dd-yyyy")
    ar1(0) = y(j, 2)
    ar1(1) = y(j, 3)
    ar1(2) = 1
    ar1(3) = y(j, 4)
    ar1(4) = y(j, 5)
    ar1(5) = Format(y(j, 7), "mm-dd-yyyy")
    ar1(6) = y(j, 1)
    ar1(7) = y(j, 8)
      If Not d.Exists(y(j, 2)) Then
        d(y(j, 2)) = ar1
       Else
        b = d(y(j, 2))
        b(2) = b(2) + 1
        b(3) = b(3) + y(j, 4)
        b(4) = b(4) + y(j, 5)
        If InStr(1, b(5), y(j, 7), vbTextCompare) = 0 Then b(5) = b(5) & ", " & y(j, 7)
        If InStr(1, b(6), y(j, 1), vbTextCompare) = 0 Then b(6) = b(6) & ", " & y(j, 1)
        If InStr(1, b(7), y(j, 8), vbTextCompare) = 0 Then b(7) = b(7) & ", " & y(j, 8)
        d(y(j, 2)) = b
      End If
  Next j
  
  With Sheets("Sheet1")
     .Columns(2).NumberFormat = "@"
    .Cells(1).Resize(UBound(y), 8) = y
  End With
  
  With Sheets("Sheet2")
    .Columns(1).NumberFormat = "@"
    .Cells(1).Resize(d.Count, 8) = Application.Index(d.items, 0, 0)
  End With
End Sub

 

[Piet Bom]

Mooie code, VenA.
Wat is het snellere alternatief ? Het maken van de code of het uitvoeren van de code.
Voor dat laatste heb ik het via de timestamps vergeleken en jouw code en de mijne doen er rond de 5 seconden over

 

[VenA]

De code is iig korter. Wat niet perse sneller of minder werk (wel minder typewerk) is. De meeste tijd bij dit soort vragen gaat toch meestal zitten in het analyseren, bedenken hoe aan te vliegen en testen.

Ik heb er ook even een timer op losgelaten en wat mij opvalt is dat er bij mij een groot verschil zit tussen het uitvoeren van de code via de debugger en het runnen vanuit het werkblad. Waarom mijn Pc zoveel moeite heeft met Gen_Output vanuit het werkblad weet ik (nog) niet. (Getest in Office 365)
Beide codes 2 x via de debugger en 2 x via het werkblad.

<F5>
Gen_Output 4,777344
Gen_Output 4,765625
VenA 2,644531
VenA 2,605469
Werkblad
Gen_Output 34,62891
VenA 2,625
Gen_Output 36,82031
VenA 2,636719