Příspěvky uživatele
< návrat zpět
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
Zdravím,
Potřeboval bych poradit s makrem.
Chtěl bych odstranit určité data ve sloupích.
Za podmínky pokud najde ve sloupci B (označené červeně) 703320 odstranit data ve sloupích B až AA (označené oranžově a červeně), ale další data ve sloupci AB zanechat.
Díky za jakoukoliv radu.
Fantasyk
elninoslov napsal/a:
Ach áno, pri tvorbe riadkov jedinečných hodnôt a ich súčtov som zabudol ešte raz použiť podmienku VADA="Rozbité".Příloha: 54005_top5-vs2.xlsx (436kB, staženo 1x)
Děkuji velmi moc - funguje perfektně!
elninoslov napsal/a:
Tá Vaša výsledná tabuľka je zle. Nesprávne názvy aj zoradenie.Příloha: 53988_53984_top5.xlsx (13kB, staženo 2x)
Teď mi to ukazuje nějaké špatné čísla - mělo by být jen prvních 5 pokud najde třeba dva tak bych chtěl, aby byla prázdná buňka.
Zdravím, potřeboval bych pomoct s vybráním TOP5 z tabulky, které obsahují největší množství. Lépe to je ukázáno v tabulce.
Děkuji za jakoukoliv pomoc
Lugr napsal/a:
Osobní číslo zde je (viz předchozí příloha).
Ano, ale jak zapisuji ty data do tabulky, jestli mají k dispozici i osobní číslo. (v tom výkazu)
Chápu asi správně, že operator vypisuje nějaký pracovni výkaz kde píše jméno, příjmení, osobní číslo, vyrobené kusy a zmetky že? Jedná se mi hlavně o to osobní číslo, které ušetří mnoho času.
Lugr napsal/a:
Seš hodnej, děkuju. Já myslel, že to půjde nějak elegantně, třeba vytvořením vlastní funkce.
Nic nechme to otevřené, já si nějak poradím, ale kažkopádně moc děkuji za pomoc.
Já klidně udělám to co jsem psal výše
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