Příspěvky uživatele

Keď prídem a bude sa mi chcieť, vyskúšam nasimulovať. Ale ak je to skutočne rovno pod C:\ tak vidím problém v prístupových právach. Windows totiž väčšinou požaduje práva správcu na priamy prístup do koreňu C:\. Skúste to dať do nejakého adresáru napr. C:\Pokus\

"...zastavilo asi na to formuláři..." - čo to presne znamená ? Hodí chybu na nejakom riadku ? Na akom ? Nenaštartuje sa vôbec ? Formulár ste tam vlastne do toho Vašeho súboru prekopíroval (stačí ho vo VBA iba pretiahnuť na Váš súbor v okne "Projekt - VBAProjekt"). V mojej prílohe Vám to funguje, alebo ani to nie ?...

PS: Ešte ma napadá, že vlastnosť Enabled tlačítka btnExport vo formulári si treba vo VBA zmeniť na False. Lebo keď je True, tak tlačítko je aktívne hneď po spustení formulára a to aj bez vybraných listov.

Heh, samozrejme :)
Ja nemám žiaden taký súbor v danom umiestnení, tak som si vyremoval apostrofom riadok, kde sa načíta obsah toho súboru. Odstránte si apostrof na začiatku riadku
'Signature = CreateObject(...
Vyššie som to už urobil.

Mne to robí takto OK:
Sub mail()
'-----------------------------------------
'DECLARE AND SET VARIABLES
Dim otlApp As Object
Dim OtlNewMail As Object
Dim Signature As String
Set otlApp = CreateObject("Outlook.Application")
Set OtlNewMail = otlApp.CreateItem(olMailItem)
'-----------------------------------------
'GET DEFAULT EMAIL SIGNATURE
Signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(Signature, vbDirectory) <> vbNullString Then
Signature = Signature & Dir$(Signature & "*.htm")
Else
Signature = ""
End If
Signature = CreateObject("Scripting.FileSystemObject").GetFile(Signature).OpenAsTextStream(1, -2).ReadAll
'-----------------------------------------
'CREATE EMAIL
'OtlNewMail.HTMLBody = Signature
With OtlNewMail
.To = "menopriezvisko@.firma.sk"
.CC = ""
.Subject = "dodatok do MOSu!"
.HTMLBody = "<HTML><BODY>Dobrý deň! Prosím o nahodenie dodatku do MOSu! Ďakujem. " & Signature
.Display
'.Send
End With
'-----------------------------------------
'CLEANUP
Set OtlNewMail = Nothing
Set otlApp = Nothing
End Sub
Inak mali ste tam zle nadefinované premenné.

Ale neviem, čo s tým medzerami pred a za odsekmi, ako ich zrušiť...

Vy chcete mať v žltých bunkách listu Data vzorce (ako text rovnice na výpočty plochy, hmotnosti a neviem čo je Názov - akože to čo je v liste Výrobek v D ???) ? To nejde. Veď tie vzorce keď majú počítať vždy niečo iné podľa toho, aký materiál je vyplnený, tak použite obdobný CHOOSE/ZVOLIT, a pre každý mat. dajte teda správny výpočet. Priamo do vzorca. Proste nemôžete mať niekde uloženú rovnicu na výpočet nejakej hodnoty, a tú rovnicu si podľa potreby vyvolať, ani nemôžete mať niekde uložený univerzálny vzorec (už nie text, ale skutočný Excelovský vzorec), lebo tie výpočty sú parametrizované vzhľadom na riadok, na ktorom sa nachádzajú. Tu som Vám upravil pár vzorcov, ale NEKONTROLOVAL som, či počítate správne, lebo ani neviem čo chcete kde a za akých okolností počítať. A premýšľať, čo by ste tak asi mohol chcieť a danou bunkou mal na mysli, sa mi vážne nechce.

Možno Vám bude stačiť riešenie od Ron de Bruin. Má ale svoje muchy. Prenesie iba niektoré orámovania (bodkočiarkované nie), niektoré podmienené formáty neprenesie (napr. údajový pruh) ale napr. farebné škály áno. Písmo a veľkosť prenáša, no celá bunka má parametre prvého písmena. Neprenáša nakreslené objekty (ovál a pod). Zlúčené bunky sú OK. Treba vyskúšať, či to bude Vám dostačovať.

Zaujímavá by mohla byť aj možnosť MailEnvelope, ktorá zachová rôzne písmo v jednej bunke aj nakreslené objekty, ale stále nedá to bodkočiarkované orámovanie alebo údajové pruhy. Táto metóda ihneď mail odosiela predvoleným kontom.

A hneď pod tým je zaujímavá možnosť, ktorá ešte potrebuje nakopírovať jednu funkciu od Ron de Bruin (to čo je pod "Test the code").

Tak skúste toto. Makro sa volá Export_Sheets, spustí formulár s výberom, vyberiete, kliknete na čudlík, exportuje vybrané do súboru, na ktorého názov sa opýta. Vysporiada sa to aj so skrytými listami v zdroji (v cieli budú zobrazené).

Private Sub CommandButton2_Click()
Dim my_range As Range
Dim c As Range
Dim radek As Long
Dim Pocet As Long

Set my_range = ActiveSheet.Range("K1:K1000")

For Each c In my_range.Cells
If c.Borders(xlEdgeBottom).LineStyle = xlDouble Then
Pocet = Pocet + 1
If Pocet = 2 Then radek = c.Row
End If
Next c
MsgBox radek
End Sub

Niečo takéto ? Dať to do Personal.xlsb a vytiahnuť tlačítko na lištu, alebo to šupnúť do doplnku (prípadne prihodiť do nejakého stávajúceho doplnku).
Sub Export_ActiveSheet()
Dim varResult As Variant
varResult = Application.GetSaveAsFilename("", FileFilter:="Excel File (*.xlsx), *.xlsx", Title:="Export ActiveSheet to Excel File")
If varResult <> False Then
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.ActiveSheet.Copy
ActiveWorkbook.SaveAs Filename:=varResult, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False, Local:=True
ActiveWorkbook.Close False
If Err.Number <> 0 Then MsgBox "Export Sheet Error !", vbCritical, "Error"
Application.DisplayAlerts = True
End If
End Sub

Ukladať zošit po každej zmene každej bunky ? To bude stráášne zdržovať. Navyše to zrušenie kopírovania, nemá na rováši Vaše makro, ale samotné ukladanie Excelu. Skúste si urobiť Ctrl+C a dať iba Save. Kopírovanie sa Vám zruší.

Hmm, problém bude možno v nejakej MS kulišárne. Takýto rýchly postup FindFormat totiž funguje iba a len, ak pred spustením makra rovnakým spôsobom dám prehľadať cez Ctrl+F formát, kde nastavím dvojitú čiaru a dám hľadať. Ak toto nahrám cez záznamník, funguje, ale iba do prípadu, pokým nevynulujem nastavenie hľadacieho okna. Ak to urobím, makro prestane fungovať, aj keď v makre nastavujem presne to isté čo nahral záznamník. Presne rovnako sa to správa na Office 2010, 2016, 2019. Musí byť najskôr použité manuálne hľadanie.

Bolo by to oproti prehľadávaniu buniek po jednej rýchlejšie. Možno niekto niečo poradí.

Ak teda cez cyklus, a jedná sa o jednotnú oblasť (jeden stĺpec) tak skúste hľadať odzadu pomocou Cells(y,x). Pretože potrebujete nájsť poslednú (alebo iba presne druhú čiaru ???, potom Vám tam chýba ukončenie cyklu po nájdení), nie všetky od začiatku.

Akú máte verziu Office ? Mne ten Váš súbor funguje správne (Office 2019 x64 SK)

Napr.:
If Not rngBunka Is Nothing Then Moja_Oblubena_Premenna = rngBunka.Row

Alebo do inkriminovanej časti doplnte:
On Error Resume Next
With ActiveSheet.Columns("K:K")
Moja_Oblubena_Premenna = .Find(What:="", After:=.Cells(Rows.Count), LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=True).Row
End With
On Error GoTo 0

V oboch prípadoch definujte Moja_Oblubena_Premenna ako Long
Dim Moja_Oblubena_Premenna as Long

Aký Vám to vráti výsledok? Mne 0. A to je zle.

Napr.:
Sub Makro1()
Dim rngBunka As Range
With Application.FindFormat.Borders(xlEdgeBottom)
.LineStyle = xlDouble
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With

With ActiveSheet.Columns("K:K")
Set rngBunka = .Find(What:="", After:=.Cells(Rows.Count), LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=True)
End With

If Not rngBunka Is Nothing Then rngBunka.Activate
End Sub

Příspěvky uživatele

Uživatelské menu

Menu

On-line nástroje

Formulář Faktura

Formulář Faktura IV

Aktivní diskuse

kontrola buniek

KT jako text do emailu

vlastní pás karet

vlastní pás karet

KT jako text do emailu

odkaz chyba

odkaz chyba