VBA - prenos dat bunek na ruzne listy, dalsi prazdny radek Vyřešeno

[MK_Vs]

Dobrý den,

v některém z minulých témat bylo popsáno jak přenést data z určitého listu - rozsahu na jiný list, vždy na následující prázdné místo.

Mám provádět několikrát denně měření různých definovaných hodnot, tyto zapisovat. Zapisováno má být na papír, což nepovažuji za vhodné a raději bych zapisoval přímo do Excelu než poté přepisovat.

V přiloženém soboru je nádled vstupních dat + vzor výstupního listu.

Jak zkopíruji vždy pouze vyplněné buňky, nebo celý rozsah B5:J5; B11:J11 atd. do cílových listů 1 - 56, tak aby bylo vkládáno vždy na následující prázdný řádek listu 1 - 56 podle číselného označení v buňkách J2; J8 ...?

Další popis je přiloženém soboru.

Děkuji.

[Reklama]

[navstevnik]

1. tlačítkem přenést jen vyplněné hodnoty z listu „Vstupní data“ do záložek s názvy podle čísel ze sloupců J a U (1; 2; .... 56).
2. Přenést vždy na následující prázdný řádek v samostatném listu. Vkládat Vložit jako - hodnoty - pouze pro vyplněné položky. Rozhodující pro přenos je aby byla vyplněna alespoň jedna buňka pro hodnotu (číslo, nebo text). Potom je možno vložit i datum, čas, prac. a poznámka (celou oblast b5:j5)
3. Smazat na listu Vstupní data bílá políčka
4. Konečná pozice na B5, Vstupní data
5. Uložit

6. GRAF definice není přesně vyřešena - spojnicový graf pro jednotlivé položky, na stejném listu, který se bude průběžně doplňovat z hodnot, které budou postupně přibývat. V grafu vložení linek maximum E3, minimum G3, střed I3. Graf č. 1 pro hodnoty z řádků D-H. Graf č. 2 pro hodnoty ze sloupců D - H. Popisky budou vždy datum sl.B a R-O nebo N sl.C.

ad 1. co sloupce AF, AQ, dalsi zalozky vlozi kdo? V I2:I3 je Leden/2010, v B11 je 15.9. ???
ad 5. Co to znamena???
ad 6. Pro kazdy radek (sloupec) pozadujes samostatny graf? nebo to ma byt skupinovy graf (pro hodnotu 1 vsechny radky,...), pak to bude graf skupinovy sloupcovy.

[MK_Vs]

ad1. - J, U, AF, AQ, není nutno řešit, bude linkováno jako pevné.
- záložky vytvořím, budou rovněž pevné jako předloha
- Leden / 2010 - zde vložím období pro jaké jsou hodnoty. Může být i týden. Pro přenos nepodstatné. Rovněž linkováno pevně.
ad5. - CTRL+S
ad6. - graf je uložen v záložce 1, data vybírána v jednom pro řádek, v drujém pro sloupec. V tomto ale nemám zatím jasno. Musím zkoušet.

[navstevnik]

Tady je pracovni verze procedury prenasejici data z listu Vstupni data na listy 1, 2, 3:

Kód: Vybrat vše

Option Explicit

Sub VstupToZalozka()
  Dim SWsht As Worksheet, SBlkBJRef As Range, SBlkBJ As Range, PodBlok As Range
  Dim i As Byte, j As Byte
  Dim TWsht As Worksheet, TBlk As Range, TOfsR As Long
  Dim TWshtN As String, SBlkEmpty As Range

  Set SWsht = Worksheets("Vstupni data")
  With SWsht
    Set SBlkBJRef = .Range("b5:j5")
    Set PodBlok = .Range("j2")  ' poradove cislo podbloku --> zalozka
  End With
  For i = 0 To 3  ' 4 bloky dat
    For j = 0 To 13  ' 14 podbloku v bloku
      TWshtN = PodBlok.Offset(6 * j, 11 * i).Value  ' nazev zalozky
      'Debug.Print PodBlok.Offset(6 * j, 11 * i).Address; " "; SBlkBJ.Offset(6 * j, 11 * i).Address; " "; TWshtN
      Set SBlkBJ = SBlkBJRef.Offset(6 * j, 11 * i)  ' podblok
      ' overeni neprazdnosti v bunkach Dxx:Jxx
      Set SBlkEmpty = Nothing
      On Error Resume Next
      Set SBlkEmpty = SBlkBJ.Resize(1, SBlkBJ.Columns.Count - 2).Offset(0, 2).SpecialCells(xlCellTypeConstants, xlNumbers)
      On Error GoTo 0
      If Not SBlkEmpty Is Nothing Then  ' jsou neprazdne Dxx:Jxx
        On Error Resume Next
        Set TWsht = ActiveWorkbook.Worksheets(TWshtN)  ' definovat cilovy list
        If Err.Number <> 0 Then GoTo ErrHandler1  ' neni zalozen
        'Debug.Print TWsht.Name
        With TWsht
          TOfsR = .Range(.Range("b3"), .Range("b3").End(xlDown)).Rows.Count - 2 ' ofset volneho radku na cilovem listu
          Set TBlk = .Range("b5:j5").Offset(TOfsR, 0) ' definovat cilovy radek
          'Debug.Print TBlk.Address
          TBlk.Value = SBlkBJ.Value ' prenest hodnoty
        End With
        On Error GoTo 0
      End If
Cont:
    Next j
  Next i
  Exit Sub
ErrHandler1:
  On Error GoTo 0
  GoTo Cont
End Sub

over funcnost, jsou osetreny neexistujici cilove listy.

[MK_Vs]

Dobrý den, děkuji, za návrh. Funguje ve vloženém souboru, který je u tohoto tématu.

Do původního dotazu vložen soubor se všemi listy.

[navstevnik]

Soubor je kde? Co je puvodni dotaz>

[MK_Vs]

Nyní je už správně nahrazen u původního dotazu.

[navstevnik]

Uvedena procedura mela osetren stav, kdy nebyly zalozeny vsechny listy 1 - 56.
Nize je doplnena o vyprazdneni bunek Dxx:Jxx a o ulozeni souboru:

Kód: Vybrat vše

Option Explicit

Sub VstupToZalozka()
  Dim SWsht As Worksheet, SBlkBJRef As Range, SBlkBJ As Range, PodBlok As Range
  Dim i As Byte, j As Byte
  Dim TWsht As Worksheet, TBlk As Range, TOfsR As Long
  Dim TWshtN As String, SBlkEmpty As Range

  Set SWsht = Worksheets("Vstupni data")
  With SWsht
    Set SBlkBJRef = .Range("b5:j5")
    Set PodBlok = .Range("j2")  ' poradove cislo podbloku --> zalozka
  End With
  For i = 0 To 3  ' 4 bloky dat
    For j = 0 To 13  ' 14 podbloku v bloku
      TWshtN = PodBlok.Offset(6 * j, 11 * i).Value  ' nazev zalozky
      'Debug.Print PodBlok.Offset(6 * j, 11 * i).Address; " "; SBlkBJ.Offset(6 * j, 11 * i).Address; " "; TWshtN
      Set SBlkBJ = SBlkBJRef.Offset(6 * j, 11 * i)  ' podblok
      ' overeni neprazdnosti v bunkach Dxx:Jxx
      Set SBlkEmpty = Nothing
      On Error Resume Next
      Set SBlkEmpty = SBlkBJ.Resize(1, SBlkBJ.Columns.Count - 2).Offset(0, 2).SpecialCells(xlCellTypeConstants, xlNumbers)
      On Error GoTo 0
      If Not SBlkEmpty Is Nothing Then  ' jsou neprazdne Dxx:Jxx
        On Error Resume Next
        Set TWsht = ActiveWorkbook.Worksheets(TWshtN)  ' definovat cilovy list
        If Err.Number <> 0 Then GoTo ErrHandler1  ' neni zalozen
        On Error GoTo 0
        'Debug.Print TWsht.Name
        With TWsht
          TOfsR = .Range(.Range("b3"), .Range("b3").End(xlDown)).Rows.Count - 2  ' ofset volneho radku na cilovem listu
          Set TBlk = .Range("b5:j5").Offset(TOfsR, 0)  ' definovat cilovy radek
          'Debug.Print TBlk.Address
          TBlk.Value = SBlkBJ.Value  ' prenest hodnoty
          SBlkBJ.Resize(1, SBlkBJ.Columns.Count - 2).Offset(0, 2).ClearContents  ' vyprazdnit radek Dxx:Jxx
        End With
      End If
Cont:
    Next j
  Next i
  ActiveWorkbook.Save
  Set TBlk = Nothing
  Set TWsht = Nothing
  Set PodBlok = Nothing
  Set SBlkBJ = Nothing
  Set SBlkBJRef = Nothing
  Set SWsht = Nothing
  Exit Sub
ErrHandler1:
  On Error GoTo 0
  GoTo Cont
End Sub

Tlacitko pouzij z Panely nastroju> Ovladaci prvky, nikoliv Formulare, zavolat proceduru VstupToZalozka zvladnes.
Body 1-5 z prilozeneho souboru jsou tedy splneny, bod 6 je tvoje parketa.

[MK_Vs]

Dobrý den, děkuji za úpravu.

Snad ještě dotaz, pokud by bude v buňce hodnotou písmeno, přenos neproběhne. Pokud zadám „x“ nebo „o“. Lze očetřit přenos nejen čísel ale i písmen?