VBA transponeren

[moensk]

voor een import moet ik een excel transponeren.
ik krijg alle openingsuren in één rij aangeleverd, doch die kan ik zo niet importeren
ik moet deze transponeren
de brondata bevat 3000 rijen ...

in bijlage een voorbeeld filetje met 2 rijen.
het tabblad "brondata" moet getransponeerd worden naar "gewenst"
iemand een VBA scriptje hiervoor ?

Bekijk bijlage test_openingsuren.xlsx

 

[snb]

- Krijg je de gegevens als Excelbestand of als tekstbestand aangeleverd ?
- Dit heeft niets met transponeren te maken, wijzig svp de titel van deze draad.
- Welke code heb je zelf al geschreven ?

 

[cow18]

Sub transponeren()
    sn = Sheets("brondata").Range("A1").CurrentRegion
    For i = 2 To UBound(sn)
        s0 = ""
        For j = 1 To 7
            s0 = s0 & sn(i, j) & "|"
        Next
        For j = 8 To UBound(sn, 2)
            s = s & s0 & sn(1, j) & "|" & sn(i, j) & vbLf
        Next
    Next
    sn = Split(s, vbLf)
    With Sheets("gewenst").Range("A1").Resize(UBound(sn))
        .Value = Application.Transpose(sn)
        .TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:="|", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1)), TrailingMinusNumbers:=True
        .Offset(, 8).NumberFormat = "h:mm;@"
    End With
End Sub

 

[SjonR]

Komt dit in de buurt?

Sub SjonR()
arr = Cells(1).CurrentRegion
ReDim arr2(UBound(arr) * 20, 8) As String
For i = 2 To UBound(arr)
    For ii = 8 To 27
        For j = 0 To 6
            arr2(n, j) = arr(i, j + 1)
            arr2(n, 7) = Format(arr(i, ii), "HH:MM:SS")
        Next
        n = n + 1
    Next
Next
Cells(2, 1).Resize(UBound(arr2) - 1 * 20, 8) = arr2
End Sub

 

[snb]

Sub M_snb()
    sn = Sheet1.Cells(1).CurrentRegion
    
    With CreateObject("scripting.dictionary")
       For j = 2 To UBound(sn)
        For jj = 8 To UBound(sn, 2)
           st = Application.Index(sn, j)
           st(8) = sn(1, jj)
           st(9) = sn(j, jj)
          .Item(.Count) = st
        Next
       Next
       
       Sheet2.Cells(100, 1).Resize(.Count, 9) = Application.Index(.items, 0, 0)
    End With
End Sub

 

[cow18]

@snb, top !

 

[snb]

@cow18

Heb er nog 1 voor je:

Sub M_snb()
   sn = Sheet1.Cells(1).CurrentRegion
   
   sp = Application.Index(sn, [index(int((row(1:40)-1)/20)+2,)], [transpose(row(1:9))])
   
   For j = 1 To UBound(sp)
      sp(j, 8) = sn(1, (j - 1) Mod 20 + 8)
      sp(j, 9) = sn((j - 1) \ 20 + 2, (j - 1) Mod 20 + 8)
   Next
   
   Sheet2.Cells(1).Resize(UBound(sp), UBound(sp, 2)) = sp
End Sub

 

[cow18]

@snb, dat kan ik, als ik het zo zie staan, netjes lezen, maar ik waag me er niet aan het zelf te fabriceren.
Maar toch ook mooi.

 

[moensk]

SNB,
als ik u script gebruik dan krijg ik fout melding 424 'object vereist'
wat dien ik aan te passen ?

Sub M_snb()
    sn = Sheet1.Cells(1).CurrentRegion
    
    With CreateObject("scripting.dictionary")
       For j = 2 To UBound(sn)
        For jj = 8 To UBound(sn, 2)
           st = Application.Index(sn, j)
           st(8) = sn(1, jj)
           st(9) = sn(j, jj)
          .Item(.Count) = st
        Next
       Next
       
       Sheet2.Cells(100, 1).Resize(.Count, 9) = Application.Index(.items, 0, 0)
    End With
End Sub

 

[snb]

Ga zelf eens op zoek; daar leer je het meeste van.
Een VBA boek voor beginners helpt je daarbij.

 

[cow18]

waarschijnlijk zit je met een nederlandstalige versie dus zit de fout in "sheetx", vervang die door onderstaande alternatieven
sheet1 = blad1 = sheets("brondata")
sheet2 = blad2 = sheets("gewenst")

 

[moensk]

Cow18 - had het intussen tijd gevonden en Sheet aangepast naar Blad
ben nu aan zoeken waarom hij maar 2 rijen neemt want mijn effectieve file bestaat uit 2600 rijen

 

[moensk]

ik heb wel deze code gebruikt en hier zoek ik hoe rijen aan te passen naar 2600 ipv 2

Sub M_snb()
   sn = Blad1.Cells(1).CurrentRegion
   
   sp = Application.Index(sn, [index(int((row(1:40)-1)/20)+2,)], [transpose(row(1:9))])
   
   For j = 1 To UBound(sp)
      sp(j, 8) = sn(1, (j - 1) Mod 20 + 8)
      sp(j, 9) = sn((j - 1) \ 20 + 2, (j - 1) Mod 20 + 8)
   Next
   
   Blad2.Cells(1).Resize(UBound(sp), UBound(sp, 2)) = sp
End Sub

 

[moensk]

opgelost heb ....(row(1:40).... aangepast naar ...(row(1:52000)....