Příspěvky uživatele
< návrat zpět
Asi jo.
Pokud máš MSO 2007 tak v menu Korespondence klikni myší na Pravidla. Třeba to bude jasné.
Lon
Netuším co máš na mysli
.. jen nevím jak tam vkládáš Další záznam? To tam píšeš ručně nebo jak?
Okno s upozorněním, je "součástí" hromadné korespondence. Říká Ti, že tam existuje propojení na jiný dokument. Bude se ukazovat pokaždé, nechápu co Ti na tom vadí. Jedno kliknutí myší navíc?
Lon
Tak co jsi vykoumal?
Můžeme to zkusit, nebude to porpvé ani naposledy 
IMHO, stačí jeden UserForm, kdy po jednotlivých kategoriích bude načítat daná data k subkategorii, atd.....
Snad.
Záleží také na struktuře dat.
Lon
Přemýšlím o nejjednodušším řešení. Pokud jde pouze o informaci, pak by bylo vhodné vložit místo hodnoty vzorec, který by v případě platné hodnoty tuto zobrazil, v případě výmazu známky by pak vložil hodnotu:
např. -1.
Pokud by však někdo odstranil celý řádek i s daty (tedy "Odstranit řádek") vznikaly by pak chyby s neexistujícím odkazem.
Ovšem vše jde také řešit elegantněji a to zamčením sešitu (listu) proti úpravám.
Řešení je na Vás.
Lon
NZ,
Budu o tom uvažovat, ale spíše mírně pokročilý. 
Lon
Tak jsem si odpověděl sám.
Váše komletní makro s mými drobnými úpravami.
Private Sub CommandButton1_Click()
Dim rd As Single
Dim cislo As Single
rd = ActiveSheet.UsedRange.Rows.Count + 1
Cells(rd, 1) = ComboBox2.Text
If CheckBox1.Value = True Then Cells(rd, 3) = "ANO" Else Cells(rd, 3) = "NE"
cislo = TextBox2
Cells(rd, 4) = cislo
Cells(rd, 5) = TextBox1
Call Dopln_do_znamka(ComboBox2.Text, cislo)
End Sub
Private Sub CommandButton2_Click()
Me.Hide
End Sub
Private Sub UserForm_Activate()
ComboBox2.Clear
Call nacti_seznam
'ComboBox2.AddItem "Adam Janků"
'ComboBox2.AddItem "Petr Král"
'ComboBox2.AddItem "Karel Nekrál"
End Sub
Private Sub Dopln_do_znamka(Jmeno, znamka)
Dim rd_start As Single
Dim sl_start As Single
rd_start = 6
sl_start = 3
While Sheets("Známka").Cells(rd_start, 2) <> Empty
If Sheets("Známka").Cells(rd_start, 2) = Jmeno Then
While Sheets("Známka").Cells(rd_start, sl_start) <> Empty
sl_start = sl_start + 1
Wend
Sheets("Známka").Cells(rd_start, sl_start) = znamka
Exit Sub
End If
rd_start = rd_start + 1
Wend
End Sub
Private Sub nacti_seznam()
Dim rd As Single
rd = 6
While Sheets("Známka").Cells(rd, 2) <> Empty
ComboBox2.AddItem Sheets("Známka").Cells(rd, 2)
rd = rd + 1
Wend
End Sub
Lon
Možná by bylo vhodné několik upřesnění.
Kde bude uložen seznam osob (předpokládám list Známka) a také předpokládám, že budete chtít načítat tento seznam do pole ve formuláři.
Lon
Princip je, že se mění údaje v listu Word, tak se při otevření souboru Objednávka.doc data načtou z excelové tabulky. To je hromadná korespondence, umí toho mnohem víc, ale toto je pro Tvůj případ dostačující.
Tedy při zápisu položek do faktury se také musí přenést do listu Word. Jedno jakým způsobem, ručně nebo automaticky.
Moc nerozumím větě:
Asík by to nešlo nastavit nějakým makrem, aby se to dělalo automaticky, že? Třeba že faktura by byla uložena ve stejném adresáři jako excel...
Co by se mělo dělat automaticky?
Psal jsem, že podmínkou pro správné fungování je mít uložené oba zdrojové soubory (Excel i Word) v jednom adresáři, pak se při změně nemusí stále hledat nová cesta k souboru s daty.
Lon
Není zač, snad to bude již v pořádku.
Lon
Pak tato úprava by měla dostačovat. Netestoval jsem, jen upravil původní kód.
Špatně pochopeno ze zadání.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'test na změnu položky A2
If ActiveCell.Row = 2 And ActiveCell.Column = 2 Then ' nejsi na buňce A2
Jmeno = Cells(2, 2)
If Cells(2, 151) = Jmeno Then
' položka se shoduje - nedělej nic
Exit Sub
Else
' ulož si položku pro příští porovnání
Cells(2, 151) = Jmeno
End If
Sesit = "MyJob"
List = ActiveSheet.Name
' číslo listu pro přejmenování
pocet = 6
' přejmenuj jej na požadovaný název
Sheets(pocet).Name = Jmeno
' otevři sešit - v tomto případě MyJob - uložený ve stejném adresáři
Workbooks.Open Filename:=Sesit + ".xlsx"
' zkopíruj oblast buněk A1 až EU35
Workbooks(Sesit).Sheets(Jmeno).Range("A1", "EU35").Copy
' ulož ji do listu 6
Workbooks("Ulohy").Sheets(Jmeno).Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' potlačení hlášky o oblasti kopírování ve schránce
Application.DisplayAlerts = False
' zavři sešit MyJob
Workbooks(Sesit).Close
Application.DisplayAlerts = True
Application.CutCopyMode = False
Sheets(List).Select
End If
End Sub
Samozřejmě. že neznám data Listu3 použil jsem
' ulož si položku pro příští porovnání
Cells(2, 151) = Jmeno
Buňku Cells(2,151) - tedy "EV2" lze zvolit za jinou vhodnou pro data v listu.
Z tohoto důvodu jsou ukázky vhodné.
Požadavek na kopii byly DATA - tedy funkce PasteSpecial...
Lon
Tak se podívej do těch skrytých listů, samé odkazy #REF!
Něco bylo přemístěno a tak žádné vzorce nemohou fungovat.
Lon
No, takže jinak.
Spousta chyb v sešitě, nefunguje to co má.
Vytvoř si tam list, který se bude jmenovat třeba Word, do něj na první řádek zapiš nadpisy položek, které chceš mít v tom dokumentu (jako záhlaví sloupců).
Pak tam vlož data (okopírováním, makrem), to je mi jedno.
Poté Ti na to vytvořím hromadku, ale abych tohle ještě louskal, opravoval a mořil se s tím, na to fakt nemám čas.
Díky za pochopení.
Lon
Co mě asi tak napadá.
Samozřejmě musí toto makro být umístěno na Listu3 v sekci Worksheet_SelectionChange!
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'test na změnu položky A2
If ActiveCell.Row = 2 And ActiveCell.Column = 2 Then ' nejsi na buňce A2
Jmeno = Cells(2, 2)
If Cells(2, 151) = Jmeno Then
' položka se shoduje - nedělej nic
Exit Sub
Else
' ulož si položku pro příští porovnání
Cells(2, 151) = Jmeno
End If
Sesit = "MyJob"
List = ActiveSheet.Name
pocet = Sheets.Count
' přidej nový list do sešitu Ulohy
Sheets.Add After:=Sheets(pocet)
' přejmenuj jej na požadovaný název
Sheets(pocet + 1).Name = Jmeno
' otevři sešit - v tomto případě MyJob - uložený ve stejném adresáři
Workbooks.Open Filename:=Sesit + ".xlsx"
' zkopíruj oblast buněk A1 až EU35
Workbooks(Sesit).Sheets(Jmeno).Range("A1", "EU35").Copy
' ulož ji do nově vytvořeného listu
Workbooks("Ulohy").Sheets(Jmeno).Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' potlačení hlášky o oblasti kopírování ve schránce
Application.DisplayAlerts = False
' zavři sešit MyJob
Workbooks(Sesit).Close
Application.DisplayAlerts = True
Application.CutCopyMode = False
Sheets(List).Select
End If
End Sub
Lon
Uživatelské menu
\nMenu
Formulář Faktura
Formulář Faktura IV
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.
Helios iNuvio
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.
RSS nejnovější články