Stránka 1 z 1
VBA - prenos dat bunek na ruzne listy, dalsi prazdny radek Vyřešeno
Napsal: 15 zář 2010 08:54
od 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.
Re: VBA - prenos dat bunek na ruzne listy, dalsi prazdny rad
Napsal: 15 zář 2010 13:18
od 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.
Re: VBA - prenos dat bunek na ruzne listy, dalsi prazdny rad
Napsal: 15 zář 2010 13:45
od 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.
Re: VBA - prenos dat bunek na ruzne listy, dalsi prazdny rad
Napsal: 15 zář 2010 16:07
od 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 Subover funcnost, jsou osetreny neexistujici cilove listy.
Re: VBA - prenos dat bunek na ruzne listy, dalsi prazdny rad
Napsal: 15 zář 2010 16:18
od 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.
Re: VBA - prenos dat bunek na ruzne listy, dalsi prazdny rad
Napsal: 15 zář 2010 16:28
od navstevnik
Soubor je kde? Co je puvodni dotaz>
Re: VBA - prenos dat bunek na ruzne listy, dalsi prazdny rad
Napsal: 15 zář 2010 18:19
od MK_Vs
Nyní je už správně nahrazen u původního dotazu.
Re: VBA - prenos dat bunek na ruzne listy, dalsi prazdny rad
Napsal: 15 zář 2010 21:42
od 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 SubTlacitko 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.
Re: VBA - prenos dat bunek na ruzne listy, dalsi prazdny rad
Napsal: 16 zář 2010 05:52
od 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?