Příspěvky uživatele

No, sice to ještě není úplně odladěné, protože vše funguje dobře jen do doby, kdy není tabulka plná, jakmile se naplní všechny řádky, náhodně se u některých buněk nezkopíruje ohraničení... ale tady je tedy použitý kód...

Sub Pridat_radek()

'Přidá řádek pod poslední plný
Range("A9").End(xlDown).Activate
ActiveCell.EntireRow.Insert
ActiveCell.Offset(1, 0).EntireRow.Copy
Selection.PasteSpecial Paste:=xlPasteFormulasAndNumberFormats, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Cells(ActiveCell.Row, 1).Select
With Selection
.Offset(1, 0).ClearContents
.Offset(1, 2).ClearContents
.Offset(1, 3).ClearContents
.Offset(1, 4).ClearContents
.Offset(1, 6).ClearContents
.Offset(1, 7).ClearContents
.Offset(1, 8).ClearContents
.Offset(1, 9).ClearContents
.Offset(1, 10).ClearContents
.Offset(1, 11).ClearContents
.Offset(1, 12).ClearContents
End With
Range("A2").Select
Application.CutCopyMode = False
End Sub

Omlouvám se za pozdější odpověď, přišel jsem o celý sešit po tom, co mi odešel Flash disk, záloha nebyla, tak jsem to dával opět dohromady...

1, Již jsem zapracoval do kodu, díky za nápad.

2, Tato část hledá 1. prázdný řádek v daném sloupci, na tento řádek se pak připíše daná poznámka, poznámek může být třeba 100...

3, Učím se VBA za pochodu metodou : Pokus, omyl... Tak se nezlob, ale nějak se mi to nedaří do codu zakomponovat tak, aby bylo makro funkční, můžeš mi to přiblížit ?

4, Přidávám poznámky pouze makrem předtím do sloupce 22, nyní v novém sešitě do sloupce 20 a odtud pak beru data bez použití maker pro rozevírací seznam...

5, Pokud přidám makrem řádek a pak budu chtít přidat poznámku, poznámka se přidá jen do řádků, které jsem již v tabulce dříve měl...

6, To máš sice pravdu, ale když přidám řádek makrem a až pak přidám poznámku, nebude to v daném řádku patrné, protože makro pro přidání poznámky s tímto řádkem zatím nepočítá...asi budu muset vyhledat nějakým způsobem poslední plný řádek v tabulce a pro všechny a opět přidat poznámku i pro všechny řádky v rozmezí první až poslední v dané tabulce...(pro obě tabulky)

Jinak ty kousky codu, co si tu připsal budu muset ještě do codu nějakým způsobem doplňit, ale bude to trvat... to víš... metoda pokus, omyl :)

Přinejhorším mi snad ještě poradíš, pokud by něco nešlo...
Každopádně mnohokrát díky, bez tvých rad bych se sem nedostal ani zdaleka...

Vím že už asi jsem otravný, ale když už tu je někdo, jako ty, chtěl bych tě ještě požádat, aby ses mrkl na tento kod :

Private Sub Poznamky()
'Přidá poznámku do rozevíracího seznamu ve sloupci Poznámka

Dim t As String
Dim rd As Single 'řádek
Dim sl As Single 'sloupec

t = Application.Inputbox("Zadej poznámku")

rd = 8 'začni prohledávat od řádku 8
sl = 22 'sloupec k prohledání a zápisu

If t = "" Then
Do While Cells(rd, sl) <> ""
rd = rd + 1
Loop
Cells(rd, sl) = t
' Nastavení seznamu
Range("M8:M28").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=" & Cells(8, 22).Address & ":" & Cells(rd, sl).Address
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = "Neplatná poznámka"
.InputMessage = ""
.ErrorMessage = "Hodnota nebyla přidána do seznamu, použij tlačítko: Přidej poznámku."
.ShowInput = True
.ShowError = True
End With
End If

If t <> "" Then
Do While Cells(rd, sl) <> ""
rd = rd + 1
Loop
Cells(rd, sl) = t
' Nastavení seznamu

Range("M43:M63").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=" & Cells(8, 22).Address & ":" & Cells(rd, sl).Address
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = "Neplatná poznámka"
.InputMessage = ""
.ErrorMessage = "Hodnota nebyla přidána do seznamu, použij tlačítko: Přidej poznámku."
.ShowInput = True
.ShowError = True
End With
End If
If t <> "" Then
Do While Cells(rd, sl) <> ""
rd = rd + 1
Loop
Cells(rd, sl) = t
' Nastavení seznamu

Range("M8:M27").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=" & Cells(8, 22).Address & ":" & Cells(rd, sl).Address
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = "Neplatná poznámka"
.InputMessage = ""
.ErrorMessage = "Hodnota nebyla přidána do seznamu, použij tlačítko: Přidej poznámku."
.ShowInput = True
.ShowError = True
End With
End If
End Sub

Jde o to, že přidávám pomocí makra poznámky do rozevíracího seznamu....
Vše funguje jen do doby, kdy přidám řádek, jakmile jej totiž do tabulky přidám, makro nebere nové řádky v potaz... Dá se to nějak upravit, aby makro kalkulovalo i s řádky, které se postupně přidávají ? Bohužel však nikdy nevím, kolik jich bude...
Dalším problémem může být fakt, že ty tabulky jsou pod sebou dvě... jediné co mě momentálně napadlo je to, že bych stejný kód přidal hned za makro pro přidání řádku...
To však neřeší druhou tabulku...
Třeba tě napadne brilantnější řešení... každopádně díky.

Perfektní !!!

Musím uznat, že jsi opravdu dobrý... Nyní vše funguje tak jak má.

Thumbs up !

Tak už vím, kde je chyba, výšky řádků nejsou shodné, ale co netuším, je to, jak je to možné, když by se formáty měly kopírovat...

Předem díky za jakoukoliv pomoc.

Tak teď jsem přišel na to, že to až tak perfektní neni... Hází mi to totiž chybovou hlášku :

Run-time error 1004 Při této operaci musí mít sloučené buňky stejnou velikost. (Buňky jsou kopírovány, takže by měly mít stejnou velikost... )

Mám jakousi tabulku, kterou potřebuju překopírovat tak, aby se kopírovaly jen hodnoty a formáty buněk s ohraničením...

V označeném textu se mi zastaví debugger a nahlásí chybu viz, výše... co s tím ?

Tady raději přikládám kod...

Sub Kopirovani_stranky_za_ucelem_oprav()
Dim JmnLst As String

Application.EnableEvents = False
On Error Resume Next
Sheets("Oprava").Select
If Err.Number = 0 Then
If MsgBox("Odstranit List /Oprava ?", vbExclamation + vbYesNo) = vbYes Then
Application.DisplayAlerts = False
Sheets("Oprava").Delete
Application.DisplayAlerts = True
Else
GoTo KONEC
End If
End If
On Error GoTo 0
Sheets.Add.Name = "Oprava"
KONEC:
Application.EnableEvents = True
Sheets("Hárok1").Select
Columns("A:N").Select
Range("A2").Activate
Selection.Copy
Sheets("Oprava").Select
Range("A1").Select
ActiveWindow.Zoom = 75
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("P21").Select
Range("O5").Select
Sheets("Oprava").Select
Application.CutCopyMode = False
Sheets("Oprava").Move After:=Sheets(3)

End Sub

Perfektní díky moc, přesně takhle jsem si to představoval...

Díky moc, to druhé řešení je přesně to co potřebuji, ale jak ošetřit, aby to neházelo chybovou hlášku, když soubor již list se stejným jménem obsahuje ? Stačí mi jak vyhledat jméno listu... pak bych jej jen smazal a pokračoval v kodu, diky moc.

Ahojte, mám menší problém a netuším, jak se s ním pohnout...

Jde o toto :

Potřebuji jedním makrem vytvořit list a zkopírovat do něj tabulku z jiného listu, ovšem bez vzorců...
Problém nastává, když se pak na tento list chci opět makrem odkázat z důvodu přepsání jména listu... netuším, jak se na tento list odkázat, když předem neznám jeho název....díky za pomoc.

Zdravím, potřeboval bych poradit od nějakého odborníka :)

Mám tento problém :

Tabulka má například 2 sloupce a 10 řádků, vyplňují se tam čísla, která se pod tabulkou sčítají pomocí sumy, do teď je vše jasné, používám však makro na přidání řádku a zkopírování formátů a vzorců, takže dopředu nemohu vědět, kolik bude mít tabulka řádků... tušíte, jak to pořešit ?

Předem děkuji za jakoukoliv snahu o pomoc.

Je to lepší v tom, že opravdu kopíruje podmíněné formátování, avšak nebere požadovanou hodnotu z předposledního řádku tabulky... alespoň mi to zatím neběží... a vzorce se zatím také nekopírují...
Avšak už se blížíme k cíli :)

Omlouvám se, že jsem se neozval dříve, ale byl jsem bohužel odstřižený od internetu... chyba na ústředně..
Tady tedy posílám slíbený soubor.

Pomocné vzorce se nacházejí mezi sloupci N a Y, kdyby bylo třeba.

Bender

Jo a ještě jedna věc, složky pro vstup i výstup se nastavují v 1. listu.

Pavlusi, mohl bys prosím ještě mrknout na řešení tohoto problému ? Už to mám skoro hotové, ale napadlo mě že bych tam mohl mít spoustu chyb, tak kdyby si mi na to mrkl a dal vědět, kdyby tě třeba napadlo brilantnější řešení, dělám na tom už asi měsíc, ale jak říkám, jsem začátečník, takže to není kolikrát tou nejsnašší cestou, jak by bylo asi vhodnější...

Jde o to, že soubor měsíční report by měl fungovat asi tak, že vytáhne automaticky data z reportů umístěných ve složce data. Reporty mají různá jména a předem nemohu vědět, jaký bude název, ale ukládají se do předem známé složky, další problém je ten, že reporty mohou být s příponou .xls i .xlsx.

Soubor má již podle názvu sbírat minuty zhruba ze 60 souborů a později filtrovat a třídit data tak, aby bylo jasné, kolik bylo za každý den v měsíci odpracováno minut a ještě rozdělovat velké a malé LK (stroj). Již to mám téměř hotové, chybí jen rozdělit data a rostřídit, na tom ještě pracuji.

Kdyby tě snad napadlo, jak něco udělat lépe, nebo jednodušeji, popřípadě, kdybys našel nějaké chyby, byl bych rád, kdybys mi to pomohl odladit...

V příloze posílám svůj výtvor, který jsem splácal :)
Heslo na odemčení sešitů a VBA kodu je mepuvo9n1

Příspěvky uživatele

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje