Gegevens verplaatsen

[gast0199]

Beste,

Is het mogelijk aan de hand van VBA, dat gegevens automatisch worden gesorteerd op het getal dat voor het decimaal teken staat?

Zie mijn voorbeeld, de gegevens uit de database moet worden verplaatst naar de bestellijst. Alle cijfers beginnend met een 1 moet onder het kopje 1 staan, etc. etc.

Wie kan mij helpen?

Met vriendelijke groet,

Bslotboom

Bekijk bijlage Voorbeeld.zip

 

[gast0199]

Hierbij nog XLS-bestand:Bekijk bijlage voorbeeld (gast0199).xls

 

[oeldere]

zie deze link voor meer info over deze vraag.

 

[HSV]

Hier is een begin.
Blad 1 wordt gesorteerd van klein naar groot.
Laat op blad 'Bestellijst' de macro lopen, en zie.
Ik weet natuurlijk niet of het een 'tv', 'playstation' of wat dan ook is.

Misschien heb heb je er iets aan.

Sub HSV()
  Dim cl As Range, rij As Integer, rijnr As Integer, sq As Variant
  On Error Resume Next
       Sheets("Bestellijst").Range("A1:G" & Cells(Rows.Count, 7).End(xlUp).Row).Clear
       On Error GoTo 0
   With Worksheets("Geïmporteerde Bestellijst")
    .Range("A2:F" & .Cells.SpecialCells(xlCellTypeLastCell).Row).Sort .[A2], xlAscending

    For Each cl In .Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
      If cl > 0 Then
       With Sheets("Bestellijst")
    sq = "Product" & "|" & "Item " & "|" & "   # " & "|" & "  Bij" & "|" & " Productkosten " & "|" & "  Netto prijs" & "|"
       Range("B1").Resize(, 6) = Split(sq, "|")
         .Cells(.Rows.Count, 2).End(xlUp).Offset(2, -1) = CInt(cl)
         
           rij = WorksheetFunction.Match(CInt(cl), .Columns(1), 0)
            rijnr = .Cells(rij, 2).CurrentRegion.Rows.Count
            .Cells(rij + rijnr, 2).Resize(, 6).Value = cl.Resize(, 6).Value
            .Cells(rij + rijnr + 1, 1).EntireRow.Insert
            .Cells(rij + rijnr + 2, 2) = "Totaal"
            .Cells(rij + rijnr + 2, 7).Formula = "=SUM(" & .Cells(rij, 7).Address & ":" & .Cells(rij + rijnr + 1, 7).Address & ")"
            .Cells(rij + rijnr + 2, 7).Interior.ColorIndex = 6
        End With
       End If
    rij = 0
   rijnr = 0
      Next cl
     End With
 With Sheets("bestellijst")
   .Columns.AutoFit
  End With
End Sub