VB og transponering

Du er velkommen til at sende mig dit ark fd@win-consult.com

Ark er mailet :-)

Jeg har pt. trukket mig pga. tid.

Send arket til mig - så kigger jeg på det: rvejemad@sca.csc.com

Prøv at teste denne .
Du bliver bedt om at angive/markere det celleområde der skal transponeres og hvortil.

Sub transp()
  Dim var
  Dim x As Integer, y As Integer, z As Byte
  Dim uniq As New Collection
  Dim StartNy As Range
  Dim Omr As Range
  Set Omr = Application.InputBox(prompt:="Angiv område for transponering ", Type:=8)
  Set StartNy = Application.InputBox(prompt:=" start på nyt område ?", Type:=8)
  Application.ScreenUpdating = False
  var = Omr
  On Error Resume Next
  For x = 1 To UBound(var, 1)
    uniq.Add var(x, 1), CStr(var(x, 1))
  Next
  y = 1
  With StartNy
    For x = 1 To uniq.Count
      .Offset(x - 1, 0) = uniq(x)
      z = 1
      Do
        .Offset(x - 1, z) = var(y, 2)
        y = y + 1
        z = z + 1
      Loop Until var(y, 1) <> uniq(x)
    Next
  End With
End Sub

<rvm> ark er sendt !
<bak> prøver din løsning af her i weekenden :-)

Denne transponer-funktioner er testet og virker:

Function MinTransponer(ByRef arrayOriginal As Variant) As Variant

    Dim x As Integer, y As Integer, i As Integer, j As Integer, TransponerTabel() As Variant
    x = UBound(arrayOriginal, 1)
    y = UBound(arrayOriginal, 2)
   
    ReDim TransponerTabel(y, x)
   
    For i = 0 To x
        For j = 0 To y
            TransponerTabel(j, i) = arrayOriginal(i, j)
        Next
    Next
    MinTransponer = TransponerTabel
   
End Function


Her er et kald til funktionen:
MinTransponer(rsProdukter.GetRows(rsProdukter.RecordCount))
Jeg kalder med antallet af poster ifm. at de er hentet via ADO

Torben

Jss -> er spørgsmålet besvaret ??

Godt spørgsmål...

Jaee Torben, men det giver jeg ikke point for :-)

Hej Bak og Torben

Sorry - men jeg har været "sat ud af spillet" af personlige årsager de seneste uger, men er nu tilbage igen. Begge forslag er gode og jeg kan bruge begge, så derfor deler jeg points 50-50 imellem jer.

Venlig hilsen
Janus

Men kan I ikke lige afgive et svar, så jeg kan tildele points. I har indtil videre kun afgivet kommentarer og dem kan jeg ikke tildele points :-)
Janus

ok, godt du er tilbage igen ...:-)

Godt at høre, at du kunne bruge svarene.