Rangschikken

[stefano]

Ik krijg een extern bestand aangeleverd met data.

In 1 of meerdere rijen staat info over eenzelfde artikel. Ik wil die info naar 1 rij in een ander tabblad overzetten. Op die manier komt een tabel te voorschijn.

Omdat ik deze handeling dagelijks dien te herhalen ben ik op zoek naar een macro die dit uitvoert.

In bijlage een voorbeeldbestand met de aangeleverde data en anderzijds een tabblad waarin ik manueel de waarden heb ingetikt.

Mocht iemand hier eens willen naar kijken dan zou ik dat waarderen.

dank alvast,

Stefano

 

[jkpieterse]

In welke vorm (met welke extensie) wordt jou dat bestand precies aangeleverd? CSV? TXT? xlsx?

 

[stefano]

dat is in .xls

Niettemin worden cijfers geëxporteerd naar dit bestand als tekst. Vervelende zaak maar daar kan ik niets aan veranderen.

 

[jkpieterse]

Als je het xls bestand opent in notepad, hoe ziet het er dan uit? Ik wed dat het onder de motorkap gewoon een plat tekstbestandje is, een veelgebruikte truc door luie programmeurs om iets naar Excel te krijgen. Probeer eens de tips van hier: https://jkp-ads.com/articles/importtextnl.asp (maar dan voor het bestand dat jij krijgt via de mail)

 

[stefano]

Het is een .xls maar als ik het open blijkt het een .txt te zijn met scheidingsteken TAB.

 

[jkpieterse]

Als ik het niet dacht. Luie donders. Zie dus mijn artikel.

 

[JanBG]

Deze in blad1?

Private Sub Worksheet_Change(ByVal Target As Range)
    With [H:I]
 .Replace ",", "."
 .NumberFormat = "0"
 End With
End Sub

 

[HSV]

In tabblad "test" komt het resultaat.

Sub hsv()
Dim sv, i As Long, j As Long, a, b(25), getal, sd As Object
sv = Sheets("data").Cells(1).CurrentRegion
Set sd = CreateObject("scripting.dictionary")
   For i = 2 To UBound(sv)
     a = sd(sv(i, 1) & sv(i, 2) & sv(i, 3) & sv(i, 4))
     If IsEmpty(a) Then a = b
       For j = 0 To 5
         a(j) = sv(i, j + 1)
       Next
    For j = 7 To 23
      getal = Application.Match(sv(i, 7), Array("vocht 1", "", "vocht 2", "", "eiwit 1", "", "eiwit 2", "", "As 1", "", "As 2", "", "HGB", "", "Abs 1", "", "V C PL", "", "V C PL P012"), 0)
        If getal + 5 <> j Then a(j) = a(j)
    Next j
        a(getal + 5) = Trim(sv(i, 8))
        a(getal + 6) = Trim(sv(i, 9))
     sd(sv(i, 1) & sv(i, 2) & sv(i, 3) & sv(i, 4)) = a
    Next i
    
  With Sheets("test")
     .Cells(1).CurrentRegion.ClearContents
     .Cells(1).Resize(, 26) = Array(sv(1, 1), sv(1, 2), sv(1, 3), sv(1, 4), sv(1, 5), sv(1, 6), "vocht 1", "vocht 1", "vocht 2", "vocht 2", "eiwit 1", "eiwit 1", "eiwit 2", "eiwit 2", "As 1", "As 1", "As 2", "As 2", "HGB", "HBG", "Abs 1", "Abs 1", "V C PL", "V C PL", "V C PL P012", "V C PL P012")
     .Cells(2, 1).Resize(sd.Count, 26) = Application.Index(sd.items, 0, 0)
  End With
End Sub

of iets anders geschreven (staat niet in het bestand).

Sub hsv()
Dim sv, arr, i As Long, j As Long, a, b(25), getal, sd As Object
sv = Sheets("data").Cells(1).CurrentRegion
Set sd = CreateObject("scripting.dictionary")
   For i = 2 To UBound(sv)
   arr = Array(sv(1, 1), sv(1, 2), sv(1, 3), sv(1, 4), sv(1, 5), sv(1, 6), "vocht 1", "vocht 1", "vocht 2", "vocht 2", "eiwit 1", "eiwit 1", "eiwit 2", "eiwit 2", "As 1", "As 1", "As 2", "As 2", "HGB", "HBG", "Abs 1", "Abs 1", "V C PL", "V C PL", "V C PL P012", "V C PL P012", "V C PL P012")
     a = sd(sv(i, 1) & sv(i, 2) & sv(i, 3) & sv(i, 4))
     If IsEmpty(a) Then a = b
       For j = 0 To 5
         a(j) = sv(i, j + 1)
       Next
    For j = 6 To 25
      getal = Application.Match(sv(i, 7), arr, 0)
        If getal - 1 <> j Then a(j) = a(j)
    Next j
        a(getal - 1) = Trim(sv(i, 8))
        a(getal) = Trim(sv(i, 9))
     sd(sv(i, 1) & sv(i, 2) & sv(i, 3) & sv(i, 4)) = a
    Next i
  With Sheets("test")
     .Cells(1).CurrentRegion.ClearContents
     .Cells(1).Resize(, 26) = arr
     .Cells(2, 1).Resize(sd.Count, 26) = Application.Index(sd.items, 0, 0)
  End With
End Sub

 

[stefano]

Dank je wel iedereen, ik ga er mee aan de slag.

 

[jkpieterse]

Hmm, hard-coded categorien in de VBA. :-(
Waarom niet een draaitabel?

 

[stefano]

Tjah JK,

daar dacht ik ook aan, maar het lukt me (ook daar) niet om er iets goed van te maken. Mocht je me op weg zetten met een voorbeeld … welkom !!!!

Stefano

 

[AlexCEL]

Hier een draaitabel gemaakt via powerpivot/powerquery, daar kun je gegevensbereiken wat gemakkelijker omzetten van tekst naar getal.

 

[stefano]

Oeps, ik denk dat ik snap wat je bedoelt met die hard-coded.

Dat is natuurlijk mijn fout.

Ik heb de code van hsv getest op een uitgebreider bestand en die liep vast.

reden: wanneer er een item bijkomt of ontbreekt, zie de code hieronder, dan gaat het fout

      getal = Application.Match(sv(i, 7), Array("vocht 1", "", "vocht 2", "", "eiwit 1", "", "eiwit 2", "", "As 1", "", "As 2", "", "HGB", "", "Abs 1", "", "V C PL", "", "V C PL P012"),

Ik had de code al deels aangepast naar onderstaand, maar ook daarmee los ik het probleem van nieuwe of ontbrekende items niet op (stel 'vocht 1' ontbreekt of 'vocht 3' komt er bij). Hoe kan ik de lijst met variabelen aanpassen ?

Sub hsv()
Dim sv, i As Long, j As Long, a, b(25), getal, sd As Object
[COLOR=#ff0000]Dim test1, test2 As String[/COLOR]
[COLOR=#ff0000]test1 = "vocht 1"
test2 = "vocht 2"[/COLOR]
sv = Sheets("data").Cells(1).CurrentRegion
Set sd = CreateObject("scripting.dictionary")
   For i = 2 To UBound(sv)
     a = sd(sv(i, 1) & sv(i, 2) & sv(i, 3) & sv(i, 4))
     If IsEmpty(a) Then a = b
       For j = 0 To 5
         a(j) = sv(i, j + 1)
       Next
    For j = 7 To 23
      getal = Application.Match(sv(i, 7), Array([COLOR=#ff0000]test1[/COLOR], "", [COLOR=#ff0000]test2[/COLOR], "", "eiwit 1", "", "eiwit 2", "", "As 1", "", "As 2", "", "HGB", "", "Abs 1", "", "V C PL", "", "V C PL P012"), 0)
        If getal + 5 <> j Then a(j) = a(j)
    Next j
        a(getal + 5) = Trim(sv(i, 8))
        a(getal + 6) = Trim(sv(i, 9))
     sd(sv(i, 1) & sv(i, 2) & sv(i, 3) & sv(i, 4)) = a
    Next i
    
  With Sheets("test")
     .Cells(1).CurrentRegion.ClearContents
     .Cells(1).Resize(, 26) = Array(sv(1, 1), sv(1, 2), sv(1, 3), sv(1, 4), sv(1, 5), sv(1, 6), [COLOR=#ff0000]test1[/COLOR], [COLOR=#ff0000]test1, test2, test2[/COLOR], "eiwit 1", "eiwit 1", "eiwit 2", "eiwit 2", "As 1", "As 1", "As 2", "As 2", "HGB", "HBG", "Abs 1", "Abs 1", "V C PL", "V C PL", "V C PL P012", "V C PL P012")
     .Cells(2, 1).Resize(sd.Count, 26) = Application.Index(sd.items, 0, 0)
  End With
End Sub

 

[AlexCEL]

Kun je iets met de draaitabel in #12? Is erg flexibel en vereist geen programmeerwerk...

 

[stefano]

Ik heb er met geëxperimenteerd. Redelijk wat werk met ordenen en zo. Het is zeker het overwegen waard.

dank !

 

[HSV]

Flexibel genoeg?

Werkt sowieso in het bestand van mijn vorig schrijven.

Sub hsv()
Dim sv, arr, i As Long, j As Long, a, getal, sd As Object, cA As Object, hs, hs2
sv = Sheets("data").Cells(1).CurrentRegion
Set cA = CreateObject("System.Collections.ArrayList")
    For i = 1 To UBound(sv)
      If Trim(sv(i, 7)) <> "" And Not cA.contains(sv(i, 7) & "|" & sv(i, 7)) Then cA.Add Trim(sv(i, 7)) & "|" & Trim(sv(i, 7))
    Next i
       cA.Sort
            hs = cA.toarray()
            hs2 = Array(sv(1, 1), sv(1, 2), sv(1, 3), sv(1, 4), sv(1, 5), sv(1, 6))
            arr = Split(Join(hs2, "|") & "|" & Join(hs, "|"), "|")
            ReDim b(UBound(arr))


Set sd = CreateObject("scripting.dictionary")
   For i = 2 To UBound(sv)
     a = sd(sv(i, 1) & sv(i, 2) & sv(i, 3) & sv(i, 4))
     If IsEmpty(a) Then a = b
       For j = 0 To 5
         a(j) = sv(i, j + 1)
       Next
    For j = 6 To UBound(arr)
      getal = Application.Match(sv(i, 7), arr, 0)
        If getal - 1 <> j Then a(j) = a(j)
    Next j
        a(getal - 1) = Trim(sv(i, 8))
        a(getal) = Trim(sv(i, 9))
     sd(sv(i, 1) & sv(i, 2) & sv(i, 3) & sv(i, 4)) = a
    Next i
  With Sheets("test")
     .Cells(1).CurrentRegion.ClearContents
     .Cells(1).Resize(, UBound(arr)) = arr
     .Cells(2, 1).Resize(sd.Count, UBound(arr)) = Application.Index(sd.items, 0, 0)
  End With
End Sub

 

[stefano]

Tjah man , ik ben … sprakeloos (schrijfloos)

Ongelooflijk hoor dit. Heel hartelijk dank voor de code.

Ik ga proberen deze te ontleden en er 10 % van te onthouden.

Man man man

dank !!!!