PC-HELP.CZ

Ahoj všem a hlavně návštěvníkovi ;-)

Mám další problém který nejsem sám schopen vyřešit. Potřebuji v příloze vytáhnout všechna data z tabulky na listu "zadání" a překopírovat na list "výsledek". Datová oblast tabulky bude vždy 12 sloupců a 70 řádků. Díky předem za rady

Mozne reseni predstavuje procedura (uprav dle skutecnosti, hlavickovy radek na list Vysledek si vloz):

Kód: Vybrat vše

Option Explicit

Sub Vypis()
  Dim BlkKod As Range, CllK As Range, KOfsR As Long
  Dim BlkDat As Range, CllD As Range, DOfsC As Long
  Dim TBlk As Range, TOfsR As Long
  With Worksheets("Zadání")
    KOfsR = 0
    Set CllK = .Range("a2")
    Do
      KOfsR = KOfsR + 1
    Loop While Len(CllK.Offset(KOfsR, 0).Value) > 0
    DOfsC = 0
    Set CllD = .Range("b1")
    Do
      DOfsC = DOfsC + 1
    Loop While Len(CllD.Offset(0, DOfsC).Value) > 0
    Set BlkKod = .Range("A2").Resize(KOfsR, 1)
    Set BlkDat = .Range("b1").Resize(1, DOfsC)
  End With
  Set TBlk = Worksheets("Výsledek").Range("a2")
  TOfsR = 0: KOfsR = 0: DOfsC = 0
  For Each CllK In BlkKod.Cells
    For Each CllD In BlkDat.Cells
      If Len(CllK.Offset(0, DOfsC + 1).Value) > 0 Then
        TBlk.Offset(TOfsR, 0).Value = CllK.Value  ' kod
        TBlk.Offset(TOfsR, 1).Value = CllD.Value  ' datum
        TBlk.Offset(TOfsR, 2).Value = CllK.Offset(0, DOfsC + 1).Value  ' hodnota
        TOfsR = TOfsR + 1
      End If
      DOfsC = DOfsC + 1
    Next CllD
    DOfsC = 0
    KOfsR = KOfsR + 1
  Next CllK
  Set BlkKod = Nothing
  Set CllK = Nothing
  Set BlkDat = Nothing
  Set CllD = Nothing
  Set TBlk = Nothing
End Sub

Super, díky moc ... Ještě to otestuji ...

PC-HELP.CZ

VBA Excel - vypsání dat z tabulky

VBA Excel - vypsání dat z tabulky

Re: VBA Excel - vypsání dat z tabulky

Re: VBA Excel - vypsání dat z tabulky Vyřešeno