Já to tedy moc nechápu z toho příkladu
Při spuštění UF se načte poslední řádek do TB1
a pak při každé změně na listu.
Toto umísti do modulu listu
Private Sub Worksheet_Change(ByVal Target As Range)
Call hodnotatextboxu
End Sub
Toto do obyčejného modulu
Sub hodnotatextboxu()
UserForm1.TextBox1 = Cells(Rows.Count, "A").End(xlUp).Row
End Sub
A toto do formuláře
Private Sub UserForm_Initialize()
Call hodnotatextboxu
End Sub
Pokračování tady
http://wall.cz/index.php?m=topic&id=17487
Buď použít pomocný sloupec nebo tak jak si dělal.
Ty data tam od někud vkládáš?
Patří zároveň k tomuto tématu.
http://wall.cz/index.php?m=topic&id=17486
Příště není potřeba zakládat nové téma, stačí dát odpovědět.
Není tam osetreno kdyby nekdo zadal 5smenu na zacatku (místo za 4 tak pred 1)
Stačí upravit název listu kam se budou kopírovat prohřešky.
Umístit do modulu listu mesice.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim smena As Byte, pocetsmen As Byte
Dim listprohresku As Object, radekprohresku As Integer
'***** test zda je ranni po nocni
If Cells(Target.Row, 1) = "R" And Target.Value = "x" And Target.Offset(1, -1).Value = "x" Then
MsgBox "Nelze zadat ranní smenu po nocní !!! ", vbCritical
With Application
.EnableEvents = False
.Undo
.EnableEvents = True
End With
End If
'***** test zda 5 smen za sebou
If Target.Value = "x" Then
For smena = 1 To 4
If Cells(Target.Row, Target.Column - smena) = "x" Then
pocetsmen = pocetsmen + 1
End If
Next smena
If pocetsmen = 4 Then
If MsgBox("Pátá smena za sebou!! " & vbNewLine & vbNewLine & "Chcete ponechat?", vbInformation + vbYesNo) = vbNo Then
With Application
.EnableEvents = False
.Undo
.EnableEvents = True
End With
Else
Set listprohresku = Sheets("jmenolistu")
radekprohresku = listprohresku.Cells(Rows.Count, "A").End(xlUp).Row + 1
listprohresku.Cells(radekprohresku, 1) = Cells(Target.Row, "B")
listprohresku.Cells(radekprohresku, 2) = Cells(4, Target.Column) & "." & Format(Cells(3, "B"), "mm") & "." & Cells(4, "B")
End If
End If
End If
End Sub
Asi bych tam dal
If ComboBox1 <> "" Then 'Revizní dvířka
neb chceš kontrolovat jestli je něco vybráno v ComboBoxu.
Pokud tomu tak není tak čeho chceš dosáhnout tím TRUE?
Chtělo by to přílohu, osobně s tím zkušenost nemám.
Chtělo by to nějaká data, takto nevím.
Něco málo umím v Excelu, ale že bych byl génius, to určitě ne.
Když můžu pomůžu. Jsou tací co za to něco i dají nebo chtějí dát, ale to vše záleží na zadavately. Kolikrát potěší jen poděkování.
Dělám to ve volném čase abych si trochu odpočinul od jiného programování.
Do Prehledu natáhne vše z Evidence.
Osobně bych zrušil to vlastní formátování buňek a vše psal makrem.
Vlož do modulu listu Evidence
Sub PrevodDoEvidence()
Dim radek As Integer, radekshPrehled As Integer
Dim shPrehled As Object
Set shPrehled = Sheets("PREHLED")
radekshPrehled = 3
For radek = 4 To Cells(Rows.Count, 1).End(xlUp).Row
shPrehled.Cells(radekshPrehled, "A") = Cells(radek, "A")
shPrehled.Cells(radekshPrehled + 1, "A") = Cells(radek, "U")
shPrehled.Cells(radekshPrehled + 2, "A") = Cells(radek, "V")
shPrehled.Cells(radekshPrehled, "C") = Cells(radek, "B")
shPrehled.Cells(radekshPrehled + 1, "C") = Cells(radek, "N") & ", " & Cells(radek, "O")
shPrehled.Cells(radekshPrehled + 2, "C") = Cells(radek, "I")
shPrehled.Cells(radekshPrehled, "E") = Cells(radek, "CT")
shPrehled.Cells(radekshPrehled + 1, "E") = "ODPRACOVAL:" 'nevim zda je potreba vzorce
shPrehled.Cells(radekshPrehled + 1, "F") = Cells(radek, "Q")
shPrehled.Cells(radekshPrehled + 2, "F") = Cells(radek, "R")
shPrehled.Cells(radekshPrehled, "G") = Cells(radek, "AG")
shPrehled.Cells(radekshPrehled + 1, "G") = Cells(radek, "Y")
radekshPrehled = radekshPrehled + 4
Next radek
End Sub
Chyba bude asi někde jinde, chtělo by to přílohu.
Nikde nebylo psáno, že se má zkopírovat datumpřed každý řádek.
Sub NakopirujDoListu()
Dim radek As Byte
Dim radeklist As Integer
For radek = 9 To 15
If Cells(radek, "B") = "Jízda" Then
radeklist = Sheets("Databáze").Cells(Rows.Count, 2).End(xlUp).Row + 1
Sheets("Databáze").Range("A" & radeklist).Value _
= Range("B3").Value
Sheets("Databáze").Range("B" & radeklist & ":D" & radeklist).Value _
= Range("B" & radek & ":D" & radek).Value
ElseIf Cells(radek, "B") = "Přestávka " Then
radeklist = Sheets("Databáze").Cells(Rows.Count, 6).End(xlUp).Row + 1
Sheets("Databáze").Range("E" & radeklist).Value _
= Range("B3").Value
Sheets("Databáze").Range("F" & radeklist & ":H" & radeklist).Value _
= Range("B" & radek & ":D" & radek).Value
End If
Next radek
End Sub
Třeba takto při inicializacaci
Private Sub UserForm_Initialize()
For radek = 1 To Cells(Rows.Count, 1).End(xlUp).Row
ListBox1.AddItem Cells(radek, 1).Value
ListBox1.Column(ListBox1.ColumnCount - 3, ListBox1.ListCount - 1) = Cells(radek, 2).Value
ListBox1.Column(ListBox1.ColumnCount - 2, ListBox1.ListCount - 1) = Cells(radek, 3).Value
Next radek
End Sub
Stačí nastavit počet sloupců v listboxu a pohrát si s šířkou sloupců.
třeba tímto makrem
Sub NakopirujDoListu()
Dim radek As Byte
Dim radeklist As Integer
For radek = 9 To 15
If Cells(radek, "B") = "Jízda" Then
radeklist = Sheets("Databáze").Cells(Rows.Count, 2).End(xlUp).Row + 1
Sheets("Databáze").Range("B" & radeklist & ":D" & radeklist).Value _
= Range("B" & radek & ":D" & radek).Value
ElseIf Cells(radek, "B") = "Přestávka " Then
radeklist = Sheets("Databáze").Cells(Rows.Count, 6).End(xlUp).Row + 1
Sheets("Databáze").Range("F" & radeklist & ":H" & radeklist).Value _
= Range("B" & radek & ":D" & radek).Value
End If
Next radek
End Sub
No pro mě je tedy výhodnější mít ty obrázky v sešitě než někde ve složce. Stejně když ty obrázky načteš tak Ti zvětší velikost sešitu když dáš uložit.
Tady pokud říkáš, že budou obrázky do budoucna přibývat tak bys měl, podle mě lepší přehled.
Místo třeba 15MB by měl sešit stejně min. 8MB
Není problém to předělat aby obrázky byly ve složkách, ale určitě bych zachoval nějaké rozdělení podle listů a pak podle umístění.
Stačí na to moje jednoduché makro.
Pokud ten sešit budeš mít pouze ty a nebudeš ho nikam posílat tak třeba to měj ve složkách, ale pokud se sním bude hýbat tak bych ty obrázky nechal v sešitě.
Jinak to určitě zvládneš, stačí mít správně pojmenované obrázky.
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.
Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.