Excel VBA: Prevod "sloupcove" tabulky na "souradnicovou" tab Vyřešeno

[Adalbert]

Dobry den,

potrebuji pomoci s prevodem dat viz. priloha.
V Listu1 je pocatecni stav, kde jsou data strukturovana do radku.
V Listu2 je cilovy stav, ktereho bych chtel dosahnout. Strukturovat data z Listu1 do tabulky jakoby souradnicove.
V Listu3 pak jsou jen definovany rozsahy pole1 a pole2.

Existuje jedna funkce, prikaz pres kterou to mohu udelat,
nebo je potreba slozit nekolik funkci abych dosahl pozadovaneho stavu?

Dekuji

[Reklama]

[navstevnik]

Funkce (vzorec) pouze vraci funkcni hodnotu do bunky, ve ktere je zapsana.
Pozadovanou transformaci dat z radku do pole lze vykonat procedurou VBA.
Nize uvedena procedura z listu 3 nacte hlavicky radku a sloupcu ciloveho pole a vlozi je na list 2. Postupne prochazi radky na listu 1 a podle hodnot ve sloupcich list1!Axx:Bxx prenasi hodnoty z list1!Cxx na list 2.
Je to pracovni verze, neni jeste osetren pripad, ze na listu 1 jsou v polich hodnoty neobsazene na listu 3, otestuj:

Kód: Vybrat vše

Option Explicit

Sub Transfer()
  Dim SBlk As Range, SCll As Range
  Dim TmpBlk As Range, TmpCll As Range, ABC() As Variant, XYZ() As Variant
  Dim TWsht As Worksheet, TCll As Range, i As Integer
  Dim TOffsR As Integer, TOffsC As Integer

  ' definovat bloky
  With Worksheets("list1")
    Set SBlk = .Range("a2:a" & .Cells(.Rows.Count, "a").End(xlUp).Row)
  End With
  Set TWsht = ActiveWorkbook.Worksheets("list2")
  Set TCll = TWsht.Range("a1")

  With Worksheets("list3")
    ' definovat bloky,  nacist data, vlozit hlavicky radku a sloupcu na list2
    Set TmpBlk = .Range("a2:a" & .Cells(.Rows.Count, "a").End(xlUp).Row)
    ReDim ABC(TmpBlk.Rows.Count)
    i = 1
    For Each TmpCll In TmpBlk.Cells
      ABC(i) = TmpCll.Value
      TCll.Offset(i, 0).Value = ABC(i)
      i = i + 1
    Next TmpCll
    Set TmpBlk = .Range("b2:b" & .Cells(.Rows.Count, "b").End(xlUp).Row)
    ReDim XYZ(TmpBlk.Rows.Count)
    i = 1
    For Each TmpCll In TmpBlk.Cells
      XYZ(i) = TmpCll.Value
      TCll.Offset(0, i).Value = XYZ(i)
      i = i + 1
    Next TmpCll
  End With
  ' prochazet radkova data na list1, presouvat do pole na list2
  For Each SCll In SBlk.Cells
    With SCll
      ' nalezt ofsety  radku v polich ABC a sloupcu v polich XYZ
      For TOffsR = LBound(ABC) + 1 To UBound(ABC)
        If .Value = ABC(TOffsR) Then
          Exit For
        End If
      Next TOffsR
      For TOffsC = LBound(XYZ) + 1 To UBound(XYZ)
        If .Offset(0, 1).Value = XYZ(TOffsC) Then
          Exit For
        End If
      Next TOffsC
      'prenest data
      TCll.Offset(TOffsR, TOffsC).Value = .Offset(0, 2).Value
    End With
  Next SCll
  Set SBlk = Nothing
  Set SCll = Nothing
  Set TmpBlk = Nothing
  Set TmpCll = Nothing
  Set TWsht = Nothing
  Set TCll = Nothing
End Sub

[Adalbert]

Funguje podle predstav. Diky.