kolommen naar rijen met een cel behouden

[tepke]

Beste

voor het importeren informatie naar een ander systeem moet ik dat die ik opgeslagen heb in rijen definiëren naar rijen echter moet bij elke rij de kolom naam worden gepubliceerd en de dat er achter.
ik heb een voorbeeldje gemaakt handmatig in invoer staat de data die ik heb en in uitvoer staat de date zoals het moet worden gemaakt.

gaat om redelijk veel data die van kolommen naar rijen moeten worden gezet, graag jullie hulp

 

[VenA]

De vraag komt wel veel voor en de diverse oplossingen zijn ook makkelijk te vinden.

Met een macro

Sub VenA()
  ar = Sheets("INvoer").Cells(1).CurrentRegion
  ReDim ar1(2, 0)
  For j = 2 To UBound(ar)
    For jj = 2 To UBound(ar, 2)
      ar1(0, t) = ar(j, 1)
      ar1(1, t) = ar(1, jj)
      ar1(2, t) = ar(j, jj)
      t = t + 1
      ReDim Preserve ar1(2, t)
    Next jj
  Next j
  Sheets("Uitvoer").Cells(2, 10).Resize(t, 3) = Application.Transpose(ar1)
End Sub

 

[HSV]

Omdat 'transpose' een beperking heeft bij veel data en 'redim preserve' overbodig is.

Sub hsv()
Dim sv, i As Long, j As Long, n As Long
sv = Sheets("invoer").Cells(1).CurrentRegion
ReDim a(UBound(sv) * UBound(sv, 2), 2)
For i = 2 To UBound(sv)
 For j = 2 To UBound(sv, 2)
   a(n, 0) = sv(i, 1)
   a(n, 1) = sv(1, j)
   a(n, 2) = sv(i, j)
   n = n + 1
 Next j
Next i
Sheets("uitvoer").Cells(1).Resize(n, 3) = a
End Sub

 

[tepke]

kleine aanpassing gevraagd

beste harry

bedankt voor je programma tekst het werkt voor 99 procent, super. echter heb ik nog een kleine vraag
het eerste veld artikelnummer is een tekst veld 0123456 bij het gebruik van de formule verdwijnt de 0 en deze heb ik wel nodig voor het importeren van de gegevens in een ander bestand.
kan dat als tekst worden behouden?

Sub VenA()
  ar = Sheets("INvoer").Cells(1).CurrentRegion
  ReDim ar1(2, 0)
  For j = 2 To UBound(ar)
    For jj = 2 To UBound(ar, 2)
      ar1(0, t) = ar(j, 1)
      ar1(1, t) = ar(1, jj)
      ar1(2, t) = ar(j, jj)
      t = t + 1
      ReDim Preserve ar1(2, t)
    Next jj
  Next j
  Sheets("Uitvoer").Cells(2, 10).Resize(t, 3) = Application.Transpose(ar1)
End Sub

 

[HSV]

Kleine aanpassing.

Sub hsv()
Dim sv, i As Long, j As Long, n As Long
sv = Sheets("invoer").Cells(1).CurrentRegion
ReDim a(UBound(sv) * UBound(sv, 2), 2)
For i = 2 To UBound(sv)
 For j = 2 To UBound(sv, 2)
   a(n, 0) = sv(i, 1)
   a(n, 1) = sv(1, j)
   a(n, 2) = sv(i, j)
   n = n + 1
 Next j
Next i
With Sheets("uitvoer")
  .Columns(1).NumberFormat = "@"
  .Cells(1).Resize(n, 3) = a
End With
End Sub

 

[VenA]

Misschien zo ook wel zonder de kolom op te maken

 a(n, 0) = "'"& sv(i, 1)

 

[HSV]

Ook zo kun je nog met kolom C rekenen.

ReDim a(UBound(sv) * UBound(sv, 2), 2)[COLOR=#ff0000] as string[/COLOR]