Sorteren en Aanvullen ontbrekende nummers

Status
Niet open voor verdere reacties.
J

joskjos

Gebruiker
Lid geworden
9 sep 2013
Berichten
94
Hallo,

Ik heb een bestandje gemaakt als voorbeeld. Bekijk bijlage Sorteren en aanvullen.xlsm
Ik ben benieuwd of het mogelijk is in VBA om de ontbrekende nummers in kolom F automatisch een regel aan te laten maken en het ontbrekende nummer in te vullen?

In tabblad Gegevens staan de nummers met daarin ontbrekende nummers in kolom F.
De nummering in het voorbeeld bestand loopt van 1t/m12.
In tabblad Uitkomst staan de nummers aangevuld met de ontbrekende nummers van tabblad Gegevens kolom F.

Nu doe ik namelijk met de hand een nieuwe regel aanmaken en het nummertje aanvullen. Ik kan dan zelf in Kolom C en D de cellen vullen dit moet zo ook blijven.

Jos
 
Code: 
Sub hsv()
Dim sn, sq, i As Long, ii As Long, n As Long, y As Long
With Sheets("gegevens")
  sn = .Range("D4", .Cells(4, 4).End(xlDown).Address)
  sn = .Range("D4").Resize(Application.RoundUp(UBound(sn) / 12, 0) * 12, 3)
   sq = sn
 For i = 1 To Application.RoundUp(UBound(sn) / 12, 0)
  For ii = 1 + ((i - 1) * 12) To 12 + ((i - 1) * 12)
      n = n + 1
   If sn(ii - y, 3) <> n Then
      sq(ii, 1) = ""
      sq(ii, 2) = ""
      sq(ii, 3) = n
      y = y + 1
     Else
      sq(ii, 1) = sn(ii - y, 1)
      sq(ii, 2) = sn(ii - y, 2)
      sq(ii, 3) = sn(ii - y, 3)
   End If
 Next ii
 n = 0
 Next i
 .Cells(4, 10).Resize(UBound(sn), 3) = sq
End With
 
?

Code: 
sn = .Range("D4").Resize(12*(UBound(sn)\12+1), 3)
 
@HSV super bedankt!!:D Dit is precies wat ik bedoelde.

@SNB bedankt voor je aanvulling.

Is het ook mogelijk dat ik bijvoorbeeld de nummering kan aanpassen i.p.v. 12 naar 25?
Bijvoorbeeld dat de code kijkt naar de waarde in cel A1. Als daar 25 staat dat de nummering tot 25 gaat?
 
Met de waarde in A1 > max(kolom F).
Code: 
Sub hsv()
Dim sn, sq, i As Long, ii As Long, n As Long, y As Long
With Sheets("gegevens")
sn = .Range("D4").Resize(.[A1] * Application.Max(.Columns(5)), 3)
   sq = sn
  For i = 1 To Application.Max(.Columns(5), 0)
     For ii = 1 + ((i - 1) * .[A1]) To .[A1] + ((i - 1) * .[A1])
         n = n + 1
      If sn(ii - y, 3) <> n Then
         sq(ii, 1) = ""
         sq(ii, 2) = ""
         sq(ii, 3) = n
         y = y + 1
        Else
         sq(ii, 1) = sn(ii - y, 1)
         sq(ii, 2) = sn(ii - y, 2)
         sq(ii, 3) = sn(ii - y, 3)
      End If
    Next ii
      n = 0
  Next i
 .Cells(4, 10).Resize(UBound(sq), 3) = sq
End With
End Sub
 
Laatst bewerkt:
@HSV, geweldig!!:thumb: nogmaals bedankt voor je hulp. De macro werkt perfect.

Jos
 
@HSV, mag ik nog een keer gebruik maken van je hulp?

Bijgevoegd heb ik je macro in het bestandje gezet en aangepast naar 16 kolommen en categorie 1 t/m 8. Echter als er achter de categorie 3 nummer 9,10,11,12 niet aanwezig zijn dat zet de macro het wel in de kolommen met uitkomst erbij maar dan is het in eens categorie 4 geworden terwijl het 3 moet blijven.

Zie bestandje met het voorbeeld waar het fout gaat. Hopelijk weet je hier ook weer raad mee?
Bekijk bijlage Sorteren en aanvullen2.xlsm
 
Niet ingewikkelder maken hoor.
Code: 
Sub HSV()
Dim sn, sq, i As Long, ii As Long, n As Long, y As Long
With Sheets("gegevens")
sn = .Range("D4").Resize(.[A1] * Application.Max(.Columns(9)), 16)
   sq = sn
  For i = 1 To Application.Max(.Columns(9))
     For ii = 1 + ((i - 1) * .[A1]) To .[A1] + ((i - 1) * .[A1])
         n = n + 1
      If sn(ii - y, 7) <> n Then
         sq(ii, 1) = sn(ii - y, 1)
         sq(ii, 2) = sn(ii - y, 2)
         sq(ii, 3) = sn(ii - y, 3)
         sq(ii, 4) = sn(ii - y, 4)
         sq(ii, 5) = sn(ii - y, 5)
      If sn(ii - y, 7) - 1 >= .[A1] - n Or sn(ii - y, 7) <> n And sn(ii - y, 6) <> i Then
         sq(ii, 6) = sn(ii - y - 1, 6)
      Else
         sq(ii, 6) = sn(ii - y + 1, 6)
     End If
         sq(ii, 7) = n
         sq(ii, 8) = "niet aanwezig"
         sq(ii, 9) = ""
         sq(ii, 10) = ""
         sq(ii, 11) = ""
         sq(ii, 12) = ""
         sq(ii, 13) = ""
         sq(ii, 14) = ""
         sq(ii, 15) = ""
         sq(ii, 16) = ""
         y = y + 1
        Else
         sq(ii, 1) = sn(ii - y, 1)
         sq(ii, 2) = sn(ii - y, 2)
         sq(ii, 3) = sn(ii - y, 3)
         sq(ii, 4) = sn(ii - y, 4)
         sq(ii, 5) = sn(ii - y, 5)
         sq(ii, 6) = sn(ii - y, 6)
         sq(ii, 7) = sn(ii - y, 7)
         sq(ii, 8) = sn(ii - y, 8)
         sq(ii, 9) = sn(ii - y, 9)
         sq(ii, 10) = sn(ii - y, 10)
         sq(ii, 11) = sn(ii - y, 11)
         sq(ii, 12) = sn(ii - y, 12)
         sq(ii, 13) = sn(ii - y, 13)
         sq(ii, 14) = sn(ii - y, 14)
         sq(ii, 15) = sn(ii - y, 15)
         sq(ii, 16) = sn(ii - y, 16)
      End If
    Next ii
      n = 0
  Next i
 .Cells(4, 22).Resize(UBound(sq), 16) = sq
End With
End Sub
 
Het is met de telling 9,10,11,12 opgelost dat er nu categorie 3 staat ipv 4. Alleen als in categorie 3 bijvoorbeeld alleen telling 8 voorkomt dan vult hij na 8 alles netjes aan met categorie 3 alleen alles voor telling 8 klopt de telling wel maar de categorie nog niet.
Hopelijk lukt het je om hier ook iets op te vinden?


Ik krijg een bestand aangeleverd waarvan de telling nog opgesplitst moet worden dat heb ik zelf gedaan met onderstaande code en dan *100 uitvoeren
Code: 
If Sheets("Gegevens").Cells(4, 11) >= 1 Then
Cells(5, 1).EntireRow.Insert
Sheets("Gegevens").Cells(4, 11).Copy
Sheets("Gegevens").Cells(5, 10).PasteSpecial xlValues
Sheets("Gegevens").Cells(4, 11).ClearContents
Sheets("Gegevens").Range("D4:I4").Copy
Sheets("Gegevens").Range("D5:I5").PasteSpecial xlValues
Sheets("Gegevens").Cells(4, 19).Copy
Sheets("Gegevens").Cells(5, 18).PasteSpecial xlValues
Sheets("Gegevens").Cells(4, 19).ClearContents
Sheets("Gegevens").Range("L4:Q4").Copy
Sheets("Gegevens").Range("L5:Q5").PasteSpecial xlValues
End If
:

De macro maakt de telling van 2 cellen op 1 regel -> 2 regels 1 cel. Probeer het maar eens uit met de button Telling per regel.
Voor mij werkt dit prima, maar ik denk dat er ook een snellere manier is om de macro het te laten uitvoeren?

Bekijk bijlage Sorteren en aanvullen2.xlsm
 
Verander dit stukje eens.
Code: 
 If sn(ii - y, 7) - 1 >= .[A1] - n Or sn(ii - y, 6) <> i Then
         sq(ii, 6) = i
      Else
         sq(ii, 6) = sn(ii - y, 6)
     End If
 
Allereerst weer bedankt voor je hulp:) en het meedenken ik had er zelf echt niet uitgekomen tot hoever je het nu al hebt gemaakt!

Nu werkt het voor categorie 3 goed. Echter als er een categorie niet aanwezig is moet deze wel worden aangevuld. max. columns is nu columns 9. Dit is goed alleen als ik dus in kolom 9 categorie 12 ook toevoeg en 2,7,8,9,10,11 niet moet dit wel worden aangevuld met niet aanwezig.
Misschien dat in bijvoorbeeld cel A2,A3 de minimale 1 en maximale columns moeten worden aangegeven dat de macro weet welke er ontbreekt of is dat niet nodig?

zie het bestandje in de uitkomst hoe het er dan moet uitkomen te zien.

Bekijk bijlage Sorteren en aanvullen2.xlsm
 
Over een heel andere boeg.
In dit geval over sq(ii,1), sq(ii,6 t/m 8)
Code: 
Sub hsv()
Dim sh As Worksheet, sn, sq, i As Long, ii As Long, n As Long
Set sh = Sheets("gegevens")
sn = sh.Range("D4").Resize(sh.[A1] * Application.Max(sh.Columns(9)), 16)
sq = sn
With CreateObject("scripting.dictionary")
 For i = 1 To UBound(sn)
  .Item(sn(i, 6) & sn(i, 7)) = .Item(sn(i, 6) & sn(i, 7))
 Next i
 For i = 1 To Application.Max(sh.Columns(9))
     For ii = 1 + ((i - 1) * sh.[A1]) To sh.[A1] + ((i - 1) * sh.[A1])
     n = n + 1
       sq(ii, 1) = "categorie"
       sq(ii, 6) = i
       sq(ii, 7) = n
        If Not .exists(sq(ii, 6) & sq(ii, 7)) Then sq(ii, 8) = "niet aanwezig"
     Next ii
    n = 0
  Next i
 End With
 sh.Cells(4, 22).Resize(UBound(sq), 16) = sq
 End Sub
 
Helemaal TOP!!!:thumb: Heel erg bedankt dit is precies wat ik bedoelde!

Ik ga alleen nog wel even kijken of die macro button:Telling op 1 regel zetten wat sneller kan maken dan kan ik het bestandje gaan vullen met gegevens.
 
@HSV toch nog even een vraagje.

Ik heb je code aangepast zoals ik hem wil hebben en dat werkt goed. Het enige wat mij opvalt is als ik in Cel A1 = 12 en A2 = 12 invul en de categorie is gevuld tot en met 8 dan telt hij wel door tot en met categorie 12 en telling 1-12 alleen bij categorie 11 slaat hij 1-2 over hoe kan dit? De cellen blijven dan wit maar er worden wel 2 cellen overgeslagen.
Code: 
Sub hsv()

Dim sh As Worksheet, sn, sq, i As Long, ii As Long, n As Long
Set sh = Sheets("gegevens")
sn = sh.Range("C4").Resize(sh.[A1] * Application.Max(sh.Range("A2")), 20)
sq = sn
With CreateObject("scripting.dictionary")
 For i = 1 To UBound(sn)
  .Item(sn(i, 9) & sn(i, 10)) = .Item(sn(i, 9) & sn(i, 10))
 Next i
 For i = 1 To Application.Max(sh.Range("A2"))
     For ii = 1 + ((i - 1) * sh.[A1]) To sh.[A1] + ((i - 1) * sh.[A1])
     n = n + 1
      If sn(ii - y, 10) <> n Then
         sq(ii, 1) = sn(ii - y, 1)
         sq(ii, 2) = sn(ii - y, 2)
         sq(ii, 3) = sn(ii - y, 3)
         sq(ii, 4) = sn(ii - y, 4)
         sq(ii, 5) = sn(ii - y, 5)
         sq(ii, 6) = sn(ii - y, 6)
         sq(ii, 7) = sn(ii - y, 7)
         sq(ii, 8) = sn(ii - y, 8)
         sq(ii, 9) = i
         sq(ii, 10) = n
        End If
        If Not .exists(sq(ii, 9) & sq(ii, 10)) Then
         sq(ii, 1) = ""
         sq(ii, 2) = "categorie"
         sq(ii, 3) = ""
         sq(ii, 4) = ""
         sq(ii, 5) = ""
         sq(ii, 6) = ""
         sq(ii, 7) = ""
         sq(ii, 8) = ""
         sq(ii, 11) = ""
         sq(ii, 12) = "niet aanwezig"
         sq(ii, 13) = ""
         sq(ii, 14) = ""
         sq(ii, 15) = ""
         sq(ii, 16) = ""
         sq(ii, 17) = ""
         sq(ii, 18) = ""
         sq(ii, 19) = ""
         sq(ii, 20) = ""
         y = y + 1
        Else
         sq(ii, 1) = sn(ii - y, 1)
         sq(ii, 2) = sn(ii - y, 2)
         sq(ii, 3) = sn(ii - y, 3)
         sq(ii, 4) = sn(ii - y, 4)
         sq(ii, 5) = sn(ii - y, 5)
         sq(ii, 6) = sn(ii - y, 6)
         sq(ii, 7) = sn(ii - y, 7)
         sq(ii, 8) = sn(ii - y, 8)
         sq(ii, 9) = sn(ii - y, 9)
         sq(ii, 10) = sn(ii - y, 10)
         sq(ii, 11) = sn(ii - y, 11)
         sq(ii, 12) = sn(ii - y, 12)
         sq(ii, 13) = sn(ii - y, 13)
         sq(ii, 14) = sn(ii - y, 14)
         sq(ii, 15) = sn(ii - y, 15)
         sq(ii, 16) = sn(ii - y, 16)
         sq(ii, 17) = sn(ii - y, 17)
         sq(ii, 18) = sn(ii - y, 18)
         sq(ii, 19) = sn(ii - y, 19)
         sq(ii, 20) = sn(ii - y, 20)
      End If
          Next ii
    n = 0
  Next i
 End With

With Sheets("uitkomst")
 .Cells(4, 3).Resize(UBound(sq), 20) = sq
End With

End Sub
 
Plaats het bestand er even bij Jos.
 
Wat je wilt bereiken met die 20 kolommen ontgaat mij.
Ook trek je de code helemaal uit het verband door eerdere gegeven coderegels in de laatste code in te voegen.
Je overschrijft de array ook hier en daar.

Dat die twee rijen leeg bleven komt doordat 1 en 11 gelijk is aan 11 en 1 (111).
Nu aangepast.

Test het zo maar eerst.

Code: 
Sub hsv()
Dim sh As Worksheet, sn, sq, i As Long, ii As Long, n As Long
Set sh = Sheets("gegevens")
sn = sh.Range("C4").Resize(sh.[A1] * Application.Max(sh.Range("A2")), 20)
sq = sn
With CreateObject("scripting.dictionary")
 For i = 1 To UBound(sn)
  .Item(sn(i, 9) & "|" & sn(i, 10)) = .Item(sn(i, 9) & "|" & sn(i, 10))
 Next i
 For i = 1 To Application.Max(sh.Range("A2"))
     For ii = 1 + ((i - 1) * sh.[A1]) To sh.[A1] + ((i - 1) * sh.[A1])
       n = n + 1
         sq(ii, 1) = "categorie"
         sq(ii, 2) = ""
         sq(ii, 3) = ""
         sq(ii, 4) = ""
         sq(ii, 5) = ""
         sq(ii, 6) = ""
         sq(ii, 7) = ""
         sq(ii, 8) = ""
         sq(ii, 9) = i
         sq(ii, 10) = n
         sq(ii, 11) = ""
    If Not .exists(sq(ii, 9) & "|" & sq(ii, 10)) Then sq(ii, 12) = "niet aanwezig"
         sq(ii, 13) = ""
         sq(ii, 14) = ""
         sq(ii, 15) = ""
         sq(ii, 16) = ""
         sq(ii, 17) = ""
         sq(ii, 18) = ""
         sq(ii, 19) = ""
         sq(ii, 20) = ""
     Next ii
    n = 0
  Next i
 End With


With Sheets("Uitkomst")
 .Cells(4, 3).Resize(UBound(sq), 20) = sq
End With
End Sub
 
Geweldig! Ook dat probleem is weer opgelost bedankt voor alle hulp!:thumb:
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan