Macro voor het aanmaken van transferroutes

Status
Niet open voor verdere reacties.
Roeland035

Roeland035

Gebruiker
Lid geworden
30 mrt 2015
Berichten
291
Beste forumleden,

Voor mijn werkgever moet ik in het systeem transferroutes (de route die onze onderdelen kunnen afleggen) definiëren voor elke vestiging. Dit betekend dat ik per vestiging een koppeling moet maken met elke andere vestiging.

Dit zijn bijv. de vestigingen:
  • Hoofdmagazijn
  • Monteur 1
  • Monteur 2
  • Monteur 3
Dit is het gewenste resultaat:
  • KOLOM A --> KOLOM B
  • Hoofdmagazijn --> Monteur 1
  • Hoofdmagazijn --> Monteur 2
  • Hoofdmagazijn --> Monteur 3
  • Monteur 1 --> Hoofdmagazijn
  • Monteur 1 --> Monteur 2
  • Monteur 1 --> Monteur 3
  • Monteur 2 --> Hoofdmagazijn
  • Monteur 2 --> Monteur 1
  • Monteur 2 --> Monteur 3
  • Monteur 3 --> Hoofdmagazijn
  • Monteur 3 --> Monteur 1
  • Monteur 3 --> Monteur 2

Is het mogelijk om d.m.v. een macro zo'n lijst automatisch op te stellen op basis van een lijst van monteurs.

Wij hebben 38 vestigingen dus deze transferroutes lopen nogal gauw boven de 1000 en is het enorm veel handwerk om dit handmatig te doen, laat staan achteraf handmatig het te bijwerken.

Als één van jullie mij op weg kan helpen met een macro dan heel graag! Het is voor mij alweer een tijdje geleden en ik weet niet meer waar ik moet beginnen.
 

Bijlagen

  • Voorbeeldbestand.xlsx
    18,2 KB · Weergaven: 32
Laatst bewerkt:
Begin eens met een voorbeeldbestandje, want ik kan hier weinig mee zo. Ik snap ook niet wat je als resultaat wilt zien.
 
Met wat structuur en een macro.

Code: 
Sub VenA()
  ar = Sheets("Monteurs").ListObjects(1).DataBodyRange
  ReDim ar1(2, 0)
    For j = 1 To UBound(ar)
    For jj = 1 To UBound(ar)
      If ar(j, 1) <> ar(jj, 1) Then
        ar1(0, x) = ar(j, 1)
        ar1(1, x) = ar(jj, 1)
        ar1(2, x) = "AAVDSV-1"
        x = x + 1
        ReDim Preserve ar1(2, x)
      End If
    Next jj
  Next j
  Cells(1, 3).Resize(x, 3) = Application.Transpose(ar1)
End Sub
 

Bijlagen

  • Voorbeeldbestand (5).xlsb
    23,2 KB · Weergaven: 37
Of dit betekent

Code: 
Sub M_snb()
  sn = Sheets("Monteurs").ListObjects(1).DataBodyRange
  ReDim sp(UBound(sn) ^ 2 - 1, 2)
  
  For j = 0 To UBound(sp)
    If sn(j \ UBound(sn) + 1, 1) <> sn(j Mod UBound(sn) + 1, 1) Then
        sp(j, 0) = sn(j \ UBound(sn) + 1, 1)
        sp(j, 1) = sn(j Mod UBound(sn) + 1, 1)
        sp(j, 2) = "AAVDSV-1"
    End If
  Next
  
  Cells(1, 3).Resize(UBound(sp) + 1, 3) = sp
End Sub

NB. Gebruik geen samengevoegde cellen in Excel (les 1 uit het handboek)
 
Hartelijk dank VenA! Dit is precies wat ik zoek! Dit gaat mij zoveel tijd besparen :eek:
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan