VBA code voor verplaatsen cellen

[vraagje1234567]

Hey,

Ik ben momenteel bezig met een scanner en die zet gegevens in een google sheet die je vervolgens kan omzetten naar een Excel document.
Nu is het mijn bedoeling om door middel van een macro de gegevens van de tabel te sorteren per naam (deze staat in kolom B, de datum met tijd staat in kolom A) dit mag in een ander blad zijn.

hoe wil ik ze sorteren?
ik wil dat het per naam gesorteerd staat in 1 werkmap (Blad 1 bij mij), dus bijvoorbeeld in kolom A en B enkel de tijd en de naam van alles met de naam TEST 1, dan in kolom C en D alles met de naam TEST 2, in kolom E en F alles met de naam TEST 3, enzovoort.
ook wil ik dat de lijst automatisch terug leeg gaat waarvan de namen gekopieerd zijn.

ik heb al iets gemaakt maar nu wil ik dat het automatisch gaat en alles doet met 1 druk op de knop in plaats van regel per regel.
Het sorteren per naam zoals ik het nu heb gedaan gaat nog heel lang duren voor het af is. er zullen heel veel verschillende barcodenamen zijn.

Hopelijk kunnen jullie mij helpen!

ben ik niet duidelijk genoeg, zeg het maar. het is nogal moeilijk te beschrijven

Bekijk bijlage Map1.xlsm

 

[Leotaxi]

probeer het zo eens

Sub Knop1_Klikken()
Dim dic As Object, rng As Range, wks As Worksheet
Set dic = CreateObject("scripting.dictionary")
Set wks = ActiveSheet
j = 1
Application.ScreenUpdating = False
With wks
    For nrow = 2 To .Cells(Rows.Count, "B").End(xlUp).Row
        If (Not dic.exists(.Cells(nrow, "B").Value)) Then
            dic.Add .Cells(nrow, "B").Value, .Cells(nrow, "B").Value
            Set rng = .Range("A1:B" & .Cells(Rows.Count, 1).End(xlUp).Row)
            rng.AutoFilter field:=2, Criteria1:=.Range("B" & nrow)
            rng.SpecialCells(xlCellTypeVisible).Rows.Copy
            With Sheets("blad 1").Cells(1, j)
                .PasteSpecial Paste:=xlPasteValues
            End With
            .AutoFilterMode = False
            j = j + 2
        End If
    Next
    .Cells.Clear
End With
Sheets("blad 1").Columns.AutoFit
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

mvg
Leo

 

[vraagje1234567]

Merci Leo,

ik heb het nu even getest, en als ik opnieuw gegevens ingeef in het tabblad Demo, dan zijn ze niet meer gesorteerd in het andere blad, wel gesorteerd maar dan staan er bijvoorbeeld 2 verschillende namen in één kolom.

Kan je misschien sorteren op de eerste 3 letters/cijfers?

 

[Leotaxi]

wordt iets voor laat deze avond als er nog geen oplossing is, werk roept

Is het dan zo dat bestaande onderaan bijgeschreven worden en niet bestaande in nieuwe kolommen ?

mvg
Leo

 

[vraagje1234567]

ja, als er namen zijn met dezelfde naam dat deze gewoon eronder bij komen, en nieuwe namen in een nieuwe kolom.

 

[MDN111]

Dag vraagje1234567,

Toen ik je topic zag was ik ook aan 't programmeren gegaan, maar ik ben niet zo snel als Leo en toen ik zijn antwoord zag was ik er maar mee gestopt. Maar toen je reageerde met de vraag om nieuwe registraties toe te voegen aan de bestaande, heb ik m'n macro toch maar verder afgewerkt.

Zie bijlage.

Grtz,
MDN111.

 

[vraagje1234567]

Ik ga nu misschien lastig doen eh, maar kan je de rijen en kolommen omdraaien? anders gaat het document iets te ver naar rechts gaan als je me snapt.

en kan je het ook laten sorteren op de eerste 2/3 letters/cijfers? dat zou veel beter zijn.

maar wat jullie nu al hebben gedaan zou ik zelf niet kunnen merci gasten!

 

[Leotaxi]

misschien eens een voorbeeld plaatsen hoe het er uit moet zien.


mvg
Leo

 

[vraagje1234567]

zoiets als je snapt wat ik bedoel,
dus als er iets is met dezelfde naam dan is het de bedoeling dat het in de rij van die naam in kolom B terecht komt
en zoals ik al gevraagd heb, kan je ook op eerste 3 letters / cijfers sorteren in plaats van heel die naam?



mvg

 

[MDN111]

Dag vraagje1234567,

Dit zou 'm dus moeten zijn. Het testen laat ik aan jou

Zie bijlage.

Grtz,
MDN111.

 

[vraagje1234567]

zo ja, nu enkel nog sorteren op de eerste 3 letters / cijfers dan is het in orde!

merci voor wat je nu allemaal al hebt gedaan! zou het nooit kunnen

 

[MDN111]

Die laatste vraag begrijp ik niet.

Als de gegevens overgebracht zijn naar de sheet "Blad 2", dan is de eerste kolom gesorteerd. Bovenaan staat dan "A0889349022061" en als laatste "TEST 1".
Bij mij werkt het althans zo.
Zie bijlage.

Als die sortering niet de gewenste is, dan graag nog enige verduidelijking.

Grtz,
MDN111.

 

[HSV]

Gesorteerd op de eerste drie letters/cijfers.

In het voorbeeld precies hetzelfde met die gegevens.
Test het maar eens met andere namen.

Sub hsv()
Dim sn, tmp
Dim c00 As String
Dim i As Long, ii As Long, n As Long, x As Long, a As Long, j As Long, jj As Long, xx As Long, xxx As Long
sn = Sheets("demo").Cells(1).CurrentRegion
ReDim arr(UBound(sn), UBound(sn))
 For i = 2 To UBound(sn)
   If InStr(c00, sn(i, 2) & "|") = 0 Then
     c00 = c00 & sn(i, 2) & "|"
       arr(n, x) = sn(i, 2)
         For ii = 2 To UBound(sn)
           If sn(i, 2) = sn(ii, 2) Then
             x = x + 1
                arr(n, x) = sn(ii, 1)
            End If
         Next ii
           n = n + 1
            If a < x Then
              a = x
            End If
          x = 0
    End If
  Next i
  
  For j = LBound(arr, 1) To n - 1
    For jj = j + 1 To n - 1
        If Left(arr(j, 0), 3) > Left(arr(jj, 0), 3) Then
         tmp = Join(Application.Index(arr, jj + 1, 0), "|")
               
            For xx = 0 To a - 1
               arr(jj, xx) = arr(j, xx)
            Next xx
           
            For xxx = 0 To a - 1
              arr(j, xxx) = Split(tmp, "|")(xxx)
            Next xxx
        
        End If
    Next jj
Next j
Sheets("blad1").Cells(1).Resize(n, a) = arr
End Sub

 

[MDN111]

@HSV:

Prachtige code maar er scheelt nog iets aan. Wat exact kan ik uiteraard niet zeggen. Daarvoor moet ik een aantal uren je code bestuderen.

• In de Sheet "Demo" staan 36 TimeStamps. Er worden er slechts 34 overgebracht naar de Sheet "Blad1".
• Volgens #9 zou de meest recente TimeStamp in de 2de kolom moeten terecht komen. Hij komt echter in de laatste kolom terecht.

Grtz,
MDN111.

 

[HSV]

@MDN111.

Sheets("blad1").Cells(1).Resize(n, a [COLOR=#ff0000]+ 1[/COLOR]) = arr

Code achterste voren draaien, of blad demo voorsorteren.
In beide gevallen kan het met Vba.

Edit:
Code loopt van onder naar boven voor recente data (kolom B t/m ......).

Sub hsv()
Dim sn, tmp
Dim c00 As String
Dim i As Long, ii As Long, n As Long, x As Long, a As Long, j As Long, jj As Long, xx As Long, xxx As Long
sn = Sheets("demo").Cells(1).CurrentRegion
ReDim arr(UBound(sn), UBound(sn))
 For i = UBound(sn) To 2 Step -1
   If InStr(c00, sn(i, 2) & "|") = 0 Then
     c00 = c00 & sn(i, 2) & "|"
       arr(n, x) = sn(i, 2)
         For ii = UBound(sn) To 2 Step -1
           If sn(i, 2) = sn(ii, 2) Then
             x = x + 1
                arr(n, x) = sn(ii, 1)
            End If
         Next ii
           n = n + 1
            If a < x Then
              a = x
            End If
          x = 0
    End If
  Next i
  
  For j = LBound(arr, 1) To n - 1
    For jj = j + 1 To n - 1
        If Left(arr(j, 0), 3) > Left(arr(jj, 0), 3) Then
         tmp = Join(Application.Index(arr, jj + 1, 0), "|")
               
            For xx = 0 To a
               arr(jj, xx) = arr(j, xx)
            Next xx
           
            For xxx = 0 To a
              arr(j, xxx) = Split(tmp, "|")(xxx)
            Next xxx
        
        End If
    Next jj
Next j
Sheets("blad1").Cells(1).Resize(n, a + 1) = arr
End Sub