EXCEL - zápis z více listů (vždy stejná buňka) do sloupce Vyřešeno

[houmrman]

Dobrý den,
mám soubor s 481 listy obsahujícími vždy stejnou tabulku. Listy jsou pojmenovány 001;002 ... 481 Potřeboval bych vytáhnout hodnotu vždy stejné buňky ze všech listů a umístit ji do sloupce úvodního listu (adresář) pod sebe.
Ve vzorci se tedy mění pouze název listu, už pár hodin ale bohužel sedím nad tím, jak toho docílit...
(Používám MS Excel 2010 EN Beta)

Kód: Vybrat vše

A1='001'!$A$4
A2='002'!$A$4
A3='003'!$A$4
A4='004'!$A$4
až
A481='481!$A$4


Viz příloha.

[Reklama]

[navstevnik]

Prilozenou proceduru vloz v editoru VBA (Alt+F11) do standardniho modulu, uprav ci dopln radky pro dalsi prenasene bunky vcetne upravy ofsetu.
Volat z karty Vyvojar>Makra nebo v editoru VBA klavesa F5.
Over na kopii sesitu, testovano v Excelu 2007.

Kód: Vybrat vše

Option Explicit

Sub NacistZListu()
  Dim TCll As Range
  Dim TOfsR As Long
  Dim SWsht As Worksheet, SCll As Range

  Set TCll = Worksheets("adresáø").Range("b2")  ' vychozi cilova bunka
  ' prochaze vsechny listy mimo list adresar
  For Each SWsht In ActiveWorkbook.Worksheets
    If SWsht.Name <> "adresáø" Then
      Set SCll = SWsht.Range("a1")
      TCll.Offset(TOfsR, 0).Value = SCll.Offset(3, 0).Value  ' nazev
      TCll.Offset(TOfsR, 1).Value = Odstran(SCll.Offset(11, 0).Value)  ' tlf
      TCll.Offset(TOfsR, 2).Value = SCll.Offset(6, 0).Value  ' adresa
      TCll.Offset(TOfsR, 3).Value = Odstran(SCll.Offset(10, 0).Value)  ' e-mail
      TCll.Offset(TOfsR, 4).Value = Odstran(SCll.Offset(9, 0).Value)  ' reditel/ka
      TCll.Offset(TOfsR, 5).Value = Odstran(SCll.Offset(10, 1).Value)  ' web
      ' dalsi bunka: vloz radek
      'TCll.Offset(TOfsR, xx).Value = SCll.Offset(yy, zz).Value
      ' a podle cile uprav sloupcovy ofset xx a podle zdroje ofset radku yy a sloupce zz
      TOfsR = TOfsR + 1 ' ofset pro dalsi list
    End If
  Next SWsht
  Worksheets("adresáø").UsedRange.Columns.AutoFit
  ' odstranit objektove promenne
  Set TCll = Nothing
  Set SCll = Nothing
  Set SWsht = Nothing
End Sub
Private Function Odstran(Str As String)
' odstrani cast pred ":" (dvojteckou)
  Odstran = Right(Str, Len(Str) - InStr(Str, ":"))
End Function

[houmrman]

Dobrý den,
no to je naprostá senzace! Děkuju moc, ušetřilo mi to opravdu hodně práce!! :-) V makrech se nevyznám, tohle bych dohromady sám nedal! Určitě to v budoucnu ještě využiju. Ještě jednou moc a moc díky! (Jste machr)
Přeji hezký den.