• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

rijen kopieren op basis van celwaarde

Status
Niet open voor verdere reacties.

alexander321

Gebruiker
Lid geworden
25 jun 2012
Berichten
74
Wat ik zou willen is het volgende:
Personen bestellen via een bestelsite kaartjes.
Er wordt dan 1 rij opgeslagen met het aantal kaarten in een cel.
Ik heb nodig op een leeg tabblad (dat is denk ik het makkelijkste) per kaart een regel, zodat ik er een barcode aan kan koppelen.
Wie kan mij helpen met een macro hiervoor?
Alvast dank!

Voorbeeldbestand:
Bekijk bijlage kaarten_bestellen.xlsx
 
Bv.

Code:
Sub VenA()
  With Sheets("Blad1").Cells(1).CurrentRegion
    ar = .Value
    ReDim ar1(Application.Sum(.Columns(3)), 2)
    For j = 3 To UBound(ar)
      For jj = 1 To ar(j, 3)
        ar1(t, 0) = ar(j, 1)
        ar1(t, 1) = ar(j, 2)
        ar1(t, 2) = 1
        t = t + 1
      Next jj
    Next j
    .Cells(7, 1).Resize(t, 3) = ar1
  End With
End Sub
 
Code:
Sub hsv()
Dim sv, hs, i As Long, c00 As String
 sv = Cells(1).CurrentRegion
        For i = 3 To UBound(sv)
         c00 = c00 & Replace(String(sv(i, 3), " "), " ", " " & i)
        Next
     hs = Application.Transpose(Split(Trim(c00)))
   Cells(1, 10).Resize(UBound(hs), 2) = Application.Index(sv,hs, Array(1, 2))
   Cells(1, 12).Resize(UBound(hs)) = 1
End Sub
 
Laatst bewerkt:
Alles is simpel te maken mits je de kennis ervoor hebt. Voor het netwerken is het niet handig om iedereen op dezelfde rij te zetten daarnaast benoem je de beperkingen niet.
 
@VenA, klopt, voor het netwerken wel, maar het is niet practisch.
Dus wat ik graag zou willen is dat indien de volgende klant niet meer volledig op de rij kan zitten naar de eerstvolgende plek gaat dat ze wel op 1 rij zitten.
Betekent dus lege regels met stoelen, die wellicht daarna handmatig op te vullen zijn?
 
Bekijk het maar eens.
Code:
Sub TicketsVullen()
Dim sv, hs, sq, rij, i As Long, aantal As Long, c00 As String
 sv = Sheets("dump").Cells(1).CurrentRegion
        For i = 2 To UBound(sv)
         c00 = c00 & Replace(String(sv(i, 5), " "), " ", " " & i)
        Next
     hs = Application.Transpose(Split(Trim(c00)))
 With Sheets("Zitplaatsen")
  If .AutoFilterMode Then .AutoFilterMode = False
    sq = .Cells(1).CurrentRegion
    .Cells(1).CurrentRegion.Columns(1).Resize(, 4).Offset(1).ClearContents
    .Cells(2, 1).Resize(UBound(hs), 4) = Application.Index(sv, hs, Array(1, 2, 3, 4))
    .Cells(1).CurrentRegion.Columns(1).Name = "bereik"
        For i = UBound(sv) To 2 Step -1
           rij = Application.Match(sv(i, 1), .Columns(1), 0)
           aantal = Evaluate("sumproduct((bereik=" & sv(i, 1) & ")*(offset(bereik,,7)=""" & sq(i, 8) & """)*(offset(bereik,,8)=" & sq(i, 9) & "))")
           If sv(i, 5) - aantal > 0 Then .Cells(rij, 1).Resize(aantal, 4).Insert
        Next i
    .Cells(1).CurrentRegion.AutoFilter
 End With
Application.Names("bereik").Delete
End Sub

Misschien is onderstaande beter.
Code:
Sub TicketsVullen()
Dim sv, hs, sq, rij, i As Long, aantal As Long, c00 As String
 sv = Sheets("dump").Cells(1).CurrentRegion
        For i = 2 To UBound(sv)
         c00 = c00 & Replace(String(sv(i, 5), " "), " ", " " & i)
        Next
     hs = Application.Transpose(Split(Trim(c00)))
 With Sheets("Zitplaatsen")
  If .AutoFilterMode Then .AutoFilterMode = False
    .Cells(1).CurrentRegion.Columns(1).Resize(, 4).Offset(1).ClearContents
    .Cells(2, 1).Resize(UBound(hs), 4) = Application.Index(sv, hs, Array(1, 2, 3, 4))
        For i = 2 To UBound(sv)
          .Cells(1).CurrentRegion.Columns(5).Name = "bereik"
           sq = .Cells(1).CurrentRegion
           rij = Application.Match(sv(i, 1), .Columns(1), 0)
           aantal = Evaluate("sumproduct((offset(bereik,,-4)=" & sv(i, 1) & ")*(offset(bereik,,3)=""" & .Cells(rij, 8) & """)*(offset(bereik,,4)=" & .Cells(rij, 9) & "))")
           If sv(i, 5) - aantal > 0 Then .Cells(rij, 1).Resize(aantal, 4).Insert xlDown
        Next i
    .Cells(1).CurrentRegion.AutoFilter
 End With
Application.Names("bereik").Delete
End Sub
 
Laatst bewerkt:
Nu op klantnummer.
Code:
Sub TicketsVullenNieuw()
Dim sv, hs, sq, rij, i As Long, aantal As Long, c00 As String
 sv = Sheets("Dump").Cells(1).CurrentRegion
        For i = 2 To UBound(sv)
         c00 = c00 & Replace(String(sv(i, 5), " "), " ", " " & i)
        Next
     hs = Application.Transpose(Split(Trim(c00)))
 With Sheets("Zitplaatsen")
  If .AutoFilterMode Then .AutoFilterMode = False
    .Cells(1).CurrentRegion.Columns(1).Resize(, 4).Offset(1).ClearContents
    .Cells(2, 1).Resize(UBound(hs), 4) = Application.Index(sv, hs, Array(1, 2, 3, 4))
        For i = 2 To UBound(sv)
          .Cells(1).CurrentRegion.Columns(5).Name = "bereik"
           sq = .Cells(1).CurrentRegion
           rij = Application.Match(sv(i, 2), .Columns(2), 0)
           aantal = Evaluate("sumproduct((offset(bereik,,-3)=" & sv(i, 2) & ")*(offset(bereik,,3)=""" & .Cells(rij, 8) & """)*(offset(bereik,,4)=" & .Cells(rij, 9) & "))")
           If sv(i, 5) - aantal > 0 Then .Cells(rij, 1).Resize(aantal, 4).Insert xlDown
        Next i
    .Cells(1).CurrentRegion.AutoFilter
 End With
Application.Names("bereik").Delete
End Sub
 
Mooi; graag gedaan Alexander.

Onderstaande coderegel mag je nog verwijderen incl. sq, in de Dim (bovenaan).
Door aanpassingen is dat blijven staan, maar overbodig.
Code:
sq = .Cells(1).CurrentRegion
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan