Příspěvky uživatele
< návrat zpět
To bylo velké nakopnutí...
Díky zítra vyzkouším, ale jak Vás znám tak to bude fungovat perfektně.
Ještě jednou díky
Podmíněné formátování
Dát si vlastní podmínku např. =A1>0. Pro zelenou a pro červenou- =A1<0
Zdravím,
Nevíte náhodou jak můžu smazat všechny listy začínající vždy na 0? Mám listy např. 01.09.2023, 02.09.2023..... a potřeboval bych vždy na konci měsíce tyto listy smazat.
Děkuji za jakékoliv nakopnutí.
Díky
elninoslov napsal/a:
Namiesto ActiveWorkbook dajte ThisWorkbook
Děkuji
Zdravím mám makro:
Sub SaveMyFile()
ActiveWorkbook.SaveCopyAs Filename:="\\Fantasyk\Report_2023_autosave.xlsm"
Call Timer_auto
End Sub
Sub Timer_auto()
Const MINUTES As String = "45"
Application.OnTime Now() + TimeValue("00:" & MINUTES & ":00"), "SaveMyFile"
End Sub
Které mi každých 45minut uloží kopii na server, ale problém je v tom, že když někdo nebo já nechám otevřený jiný excel soubor a nechám ho aktivní, tak se mi v daný čas spustí makro jak má, ale uloží to aktuální zobrazený excel soubor místo toho původního.
Nevíte jak by to šlo ošetřit, aby to vždy uložilo jen ten soubor, ve kterém je makro?
PS: soubor, který chci uložit je proměnný, ale vždy začíná "Report_" a končí.xlsm
Díky za jakokoliv radu
Tak jsem to udělal následovně:
ThisWorkbook:
Private Sub Workbook_Open()
Const MINUTES As String = "01"
Application.OnTime Now() + TimeValue("00:" & MINUTES & ":00"), "SaveMyFile"
End Sub
Modul1:
Sub SaveMyFile()
ActiveWorkbook.SaveCopyAs Filename:="C:\Users\Zaloha\autosave.xlsm"
Call Timer
End Sub
Sub Timer()
Const MINUTES As String = "01"
Application.OnTime Now() + TimeValue("00:" & MINUTES & ":00"), "SaveMyFile"
End Sub
čas 01 byl jen pro test..
To jsem před tím taky našel, ale nějak mi to nefunguje tak jak bych si to představoval.
Při otevření sešitu bude běžet interval např. 30 minut a každých 30 minut se mi soubor uloží jako kopie na disk C:\Users\NOOB\desktop\zaloha.xlsm
,Ale zůstane aktivní stále ten původní soubor.
Abych mohl v případě pádu ihned zareagovat a otevřít tu kopii
Zdravím,
Chtěl bych ve VBA vytvořit makro, aby mi ukládalo kopii aktuálního sešitu na určité místo. ( C:\Users\NOOB\desktop\zaloha.xlsm )
Sešit je otevřený non-stop a v intervalu 2 hodin, bych potřeboval přepisovat soubor "zaloha.xlsm", abych měl zálohu v případě pádu.
Díky za jakýkoliv typ
Zdravím,
potřeboval bych poradit s přidáním více příloh do emailu.
Mám makro ve kterém posílám z listu "active" to mi funguje, ale potřeboval bych posílat ještě jeden soubor se stejnou Range, ale z listu REPORT_EN
Sub mailAscreen()
Dim OutApp As Object 'Outlook.Application
Dim OutMail As Object 'Outlook.MailItem
Dim OutAttachment As Object 'Outlook.Attachment
Dim OutPropertyAcc As Object 'Outlook.PropertyAccessor
Dim SendTo As String
Dim CC As String
Dim Subject As String
Dim ExcelCells As Range
Dim ExcelCells_EN As Range
Dim HTML As String
Dim CellsImage As String, tempCellsFile As String
Dim answer As Integer
Dim shift1 As String
Dim shift2 As String
Dim shiftall As String
answer = MsgBox("Opravdu chceš odeslat report smeny?", vbQuestion + vbYesNo + vbDefaultButton2, "Odeslání Reportu smeny")
If answer = vbYes Then
On Error GoTo bugy
Range("T11").Comment.Visible = True
Range("T11").Comment.Shape.Select True
Selection.ShapeRange.IncrementLeft -12#
Selection.ShapeRange.IncrementTop -145.25
bugy:
On Error GoTo bugy2
Range("L11").Comment.Visible = True
Range("L11").Comment.Shape.Select True
Selection.ShapeRange.IncrementLeft -12#
Selection.ShapeRange.IncrementTop -145.25
bugy2:
shift1 = Range("F12").Value2
shift1 = Format(shift1, "0.00%")
shift2 = Range("N12").Value
shift2 = Format(shift2, "0.00%")
shiftall = Range("AE3").Value
shiftall = Format(shiftall, "0.00%")
Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
Active = ActiveSheet.Name
Set ExcelCells = ThisWorkbook.Worksheets(Active).Range("A1:AF166") 'range includes cells and charts
Set ExcelCells_EN = ThisWorkbook.Worksheets("REPORT_EN").Range("A1:AF166") 'range includes cells and charts
SendTo = "ahoj@ahoj.com"
CC = "hello@hello.com"
Subject = "Report smeny - (" & Range("AA2").Value & ") -" & Range("V2").Value & " Denní: " & shift1 & " / Nocní " & shift2 & " / Total: " & shiftall
CellsImage = Replace(Timer, ".", "") & "image.jpg"
tempCellsFile = Environ("temp") & "\" & CellsImage
Save_Object_As_Picture ExcelCells, tempCellsFile
'Construct email body as HTML string, with the range image in an img tag with corresponding src='cid:xxxx.jpg' attribute
HTML = "<html>"
'HTML = HTML & "<a href=""http://www.seznam.cz"">seznam.cz</a>"
HTML = HTML & "<img src='cid:" & CellsImage & "'>"
HTML = HTML & "</html>"
Set OutApp = CreateObject("Outlook.Application") 'New Outlook.Application
Set OutMail = OutApp.CreateItem(0) 'olMailItem
With OutMail
.To = SendTo
.CC = CC
.Subject = Subject
' pridání prílohy
.Attachments.Add tempCellsFile, olByValue, 1, ""
Set OutAttachment = .Attachments.Add(tempCellsFile)
Set OutPropertyAcc = OutAttachment.PropertyAccessor
OutPropertyAcc.SetProperty PR_ATTACH_CONTENT_ID, CellsImage
.HTMLBody = HTML
' .send
.Display
End With
'Delete the temporary image file
Kill tempCellsFile
Set OutMail = Nothing
Set OutApp = Nothing
End If
For Each C In ActiveSheet.Comments
C.Visible = False
Next
ThisWorkbook.Application.Caption = " poslední odeslaný report: " & Date & " - " & Time
End Sub
Private Sub Save_Object_As_Picture(saveObject As Object, imageFileName As String)
Dim temporaryChart As ChartObject
Application.ScreenUpdating = False
saveObject.CopyPicture xlScreen, xlPicture
Set temporaryChart = ActiveSheet.ChartObjects.Add(0, 0, saveObject.Width, saveObject.Height)
With temporaryChart
.Activate
.Border.LineStyle = xlLineStyleNone 'No border
.Chart.Paste
.Chart.Export imageFileName
.Delete
End With
Application.ScreenUpdating = True
Set temporaryChart = Nothing
End Sub
Díky za radu
elninoslov napsal/a:
Takže tá funkcia si má vo VBA prečítať posledný list v poradí? Lebo takú funkcionalitu Excel inak nemá.
Alebo sú tie listy nazývané nejakým pravidlom? Napr. DD.MM.YYYY? Potom sa dá aj cez INDIRECT/NEPŘÍMÝ.ODKAZ vzorcom.
Samotné určenie času potom riešiť podmienkou IF/KDYŽ (v závislosti na predchádzajúcej odpovedi prípadne matica), ale Vy ste nenapísal jediné vodítko, ktorým smerom sa ubrať. Doplňte.
EDIT: Tu máte niektoré z príkladov, ako sa dá Váš dotaz vyložiť. Rôzne.Příloha: 55200_translate.zip (20kB, staženo 0x)
Už jsem na to přišel přes nepřímý odkaz
Díky
elninoslov napsal/a:
Mrknite napr. na stackoverflow
Skúsil som odtiaľ túto:
Function Translate$(sText$, FromLang$, ToLang$)
Dim p1&, p2&, url$, resp$
Const DIV_RESULT$ = "<div class=""result-container"">"
Const URL_TEMPLATE$ = "https://translate.google.com/m?hl=[from]&sl=[from]&tl=[to]&ie=UTF-8&prev=_m&q="
url = URL_TEMPLATE & WorksheetFunction.EncodeURL(sText)
url = Replace(url, "[to]", ToLang)
url = Replace(url, "[from]", FromLang)
resp = WorksheetFunction.WebService(url)
p1 = InStr(resp, DIV_RESULT)
If p1 Then
p1 = p1 + Len(DIV_RESULT)
p2 = InStr(p1, resp, "</div>")
Translate = Mid$(resp, p1, p2 - p1)
End If
End Function
Děkuji
Akurát jsem narazil na problém v tom, že potřebuji teďka "=translate(tady;"cz";"en")"
a místo toho tady udělat odkaz na poslední list v sešitě.
tzv. každy den se přidává nový list s datumem.
Př. nyní je 17.07.2023 a potřebuji do nového listu napsat vzorec s tímto datumem, ale problém je v tom, že po půlnoci do cca 6:30 platí staré datum tj. 17.07.2023 i když už je 18.07.2023...
Zdravím,
Chtěl bych se zeptat, jestli lze text vloženy do buněk přeložit do angličtiny.
Mám soubor, který posílám v JPG formátu emailem a chtěl bych text přeložit do angličtiny a poslat 2x JPG jednou v češtině a jednou v angličtině.
Nikde jsem nenarazil, jestli to vůbec v Excelu jde.
Díky za nakopnutí jak to udělat.
elninoslov napsal/a:
Aj tak neviem naisto, či potom dobre rozumiem...:
Sub Vymaz_B_AA()
Dim R As Long, i As Long, B(), rngBAA As Range, HLADAJ
HLADAJ = 703320
With ThisWorkbook.Worksheets("List1")
R = .Cells(Rows.Count, 2).End(xlUp).Row
B = .Cells(1, 2).Resize(R).Value2
For i = 1 To R
If B(i, 1) = HLADAJ Then
If rngBAA Is Nothing Then
Set rngBAA = .Range("B1:AA1").Offset(i - 1, 0)
Else
Set rngBAA = Union(rngBAA, .Range("B1:AA1").Offset(i - 1, 0))
End If
End If
Next i
End With
If Not rngBAA Is Nothing Then rngBAA.ClearContents
End Sub
Už ten první kód jsem si jen upravil a jelo to diky
elninoslov napsal/a:
Akurát som odoslal EDIT do príspevku. Mal som preklep v oblasti C1:AA1 vs B1:AA1.
To čo upravujete Vy, teda AB na AA, neodpovedá požiadavke, ktorú ste napísal, a to, že chcete AB hodnoty ponechať.
To .Cells(i, "AB") v kóde slúži práve na to, aby sa uložili oblasti, ktoré sa majú previesť neskôr na hodnoty. Nie zmazať ani nie ponechať vzorec. V AB je totiž vzorec, nemôžete mu zmazať zdrojové hodnoty C,B,K,AA, nezostane mu výsledok.
Já výsledek nepotřebuji jen to chci smazat což teď už to maže a zanechá jen samotný vzorec, který u toho nepotřebuji. Potřebuji jen výsledky u toho kde není 703320
elninoslov napsal/a:
Dáta v stĺpci AB je možné zanechať iba za predpokladu konverzie vzorca, ktorý sa v AB nachádza na hodnotu. Teda ten výpočet bude v AB (v daných riadkoch) ďalej nefunkčný.
Sub Vymaz_B_AA()
Dim R As Long, i As Long, B(), rngCAA As Range, rngAB As Range, rng As Range, HLADAJ
HLADAJ = 703320
With ThisWorkbook.Worksheets("List1")
R = .Cells(Rows.Count, 2).End(xlUp).Row
B = .Cells(1, 2).Resize(R).Value2
For i = 1 To R
If B(i, 1) = HLADAJ Then
If rngCAA Is Nothing Then
Set rngCAA = .Range("C1:AA1").Offset(i - 1, 0)
Set rngAB = .Cells(i, "AB")
Else
Set rngCAA = Union(rngCAA, .Range("C1:AA1").Offset(i - 1, 0))
Set rngAB = Union(rngAB, .Cells(i, "AB"))
End If
End If
Next i
End With
If Not rngAB Is Nothing Then
For Each rng In rngAB.Areas
rng.Value2 = rng.Value2
Next rng
rngCAA.ClearContents
End If
End SubPříloha: 55182_odstraneni-urciteho-textu-pomoci-makra.zip (17kB, staženo 1x)
Díky moc
jen jsem přepsal AB na AA a funguje tak jak má.
ještě jednou díky Elninoslov
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