Příspěvky uživatele

Dobrý den, upraveno.

Dobrý den.

přidáno nové makro v příloze

Dobrý den,
upravil jsem kód pro druhý sešit s číselným označením listů.
Pro automatické spouštění makra po otevření sešitu vložte do "ThisWorkbook" ještě tento příkaz

Private Sub Workbook_Open()
Call KopirujDataPredoslehoMesiacaDoPoslednehoHarku
End Sub

zde je ten upravený kód:
Sub KopirujDataPredoslehoMesiacaDoPoslednehoHarku()
Dim aktMesiac As Integer
Dim predMesiac As String
Dim nazvyMesiacov As Variant
Dim aktRok As Long, predRok As Long
Dim cesta As String, nzvPredZositu As String
Dim aktZosit As Workbook, predZosit As Workbook
Dim aktHarok As Worksheet, predHarok As Worksheet

nazvyMesiacov = Array("január", "február", "marec", "apríl", "máj", "jún", "júl", "august", "september", "október", "november", "december")

'reset mesiaca
aktMesiac = -1

' Získaj aktuálny Zošit a Hárok
Set aktZosit = ThisWorkbook
Set aktHarok = aktZosit.Sheets("Hárok2")

If aktHarok.Range("D2").Value = "" Then
MsgBox "Bunka D2:E2 je prázdná, doplnte mesiac do danej bunky"
Exit Sub
End If

' Získaj aktuálny mesiac a rok z názvu súboru
On Error Resume Next
aktMesiac = Application.Match(LCase(aktHarok.Range("D2").Value), nazvyMesiacov, 0)

If aktMesiac = -1 Then
MsgBox "Hľadaný mesiac v bunke D2:E2 """ & aktHarok.Range("D2").Value & """, je nesprávne napísaný. upravte text mesiaca."
Exit Sub
End If
aktRok = Replace(aktHarok.Range("F2").Value, "/", "")
On Error GoTo 0

If aktHarok.Range("F2").Value = "" Or aktRok = 0 Then
MsgBox "Hľadaný rok v bunke F2 """ & aktHarok.Range("F2").Value & """, je buď prázdná, alebo neobsahuje číslo roku. upravte text roku."
Exit Sub
End If

' Nastav predchádzajúci mesiac a rok
If aktMesiac = 1 Then
predMesiac = nazvyMesiacov(11)
predRok = aktRok - 1
Else
predMesiac = nazvyMesiacov(aktMesiac - 2)
predRok = aktRok
End If

nzvPredZositu = "Súhrn " & predMesiac & " " & predRok

' Nastav predpokladané prípony súborov
Dim nalezSuboru As Boolean
Dim pripona As Variant, pripony As Variant

pripony = Array(".xlsx", ".xls", ".xlsm")
nalezSuboru = False

' Skontroluj každú príponu súboru
For Each pripona In pripony
cesta = aktZosit.Path & "\" & nzvPredZositu & pripona
If Dir(cesta) <> "" Then
nalezSuboru = True
Exit For
End If
Next pripona

If Not nalezSuboru Then
MsgBox "Predchádzajúci súbor neexistuje alebo cesta nie je správna: " & aktZosit.Path & "\" & nzvPredZositu
Exit Sub
End If

' Vypnutie preblikávania obrazovky
Application.ScreenUpdating = False

' Otvor predchádzajúci Zošit
Set predZosit = Workbooks.Open(cesta)

Dim harok As Worksheet
Dim menoPosHarku As String
Dim posCisloHarku As Integer

' Nájdite posledný číselný hárok

For Each harok In predZosit.Sheets
If IsNumeric(harok.Name) Then
If CLng(harok.Name) > posCisloHarku Then
posCisloHarku = CLng(harok.Name)
menoPosHarku = harok.Name
End If
End If
Next harok

' Skontroluj, či bol nájdený číselný hárok
If menoPosHarku = "" Then
MsgBox "V predchádzajúcom zošite nebol nájdený číselný hárok."
predZosit.Close SaveChanges:=False
Exit Sub
End If

' Nastav predchádzajúci zošit
Set predHarok = predZosit.Sheets(menoPosHarku)

' Skopíruj údaje z predchádzajúceho zošitu do aktuálneho
aktHarok.Range("C13:N13").Value = Application.Transpose(predHarok.Range("C10:C21").Value)

' Zatvor predchádzajúci zošit bez uloženia zmien
predZosit.Close SaveChanges:=False
Application.ScreenUpdating = True

MsgBox "Údaje boli úspešne skopírované z " & nzvPredZositu
End Sub

dobrý den,
zkuste tohle:
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Dim bOK As Boolean
Dim OLApp As Object, oAccount As Object
Dim eMailAdresa As String, Ucet As String

eMailAdresa = "bistroumuta@gmail.com"
Ucet = "bistroumuta@gmail.com"

If MsgBox("Chcete odoslať tento súbor na email ?" & vbNewLine & eMailAdresa, vbYesNo + vbQuestion) = vbNo Then Exit Sub

On Error Resume Next
Set OLApp = GetObject(, "Outlook.Application")
If OLApp Is Nothing Then Set OLApp = CreateObject("Outlook.Application")
On Error GoTo 0

If OLApp Is Nothing Then
MsgBox "Outlook nieje možné spustiť", vbCritical
Exit Sub
End If

For Each oAccount In OLApp.Session.Accounts
If oAccount = Ucet Then
bOK = True
Exit For
End If
Next oAccount

If Not bOK Then
MsgBox "Tento účet v Outlooku neexistuje." & vbNewLine & Ucet
Exit Sub
End If

On Error Resume Next
With OLApp.CreateItem(0)
.To = eMailAdresa
.Subject = "Záloha vyučtovanie"
.Body = ""
.Attachments.Add ThisWorkbook.FullName
Set .SendUsingAccount = oAccount
.Send
End With
If Err.Number <> 0 Then
MsgBox "Počas odosielania došlo k chybe.", vbCritical
End If
On Error GoTo 0

' Properly release the object
Set OLApp = Nothing
' Close Outlook
If OLApp Is Nothing Then
CreateObject("WScript.Shell").Run "taskkill /f /im outlook.exe", 0, True
End If
End Sub

Dobrý den,
omlouvám se za špatně pochopené zadání.

Posílám upravený kód, kde nyní bere měsíc z buňky "D2:E2" a rok z buňky "F2".

Starý kód smažte a nahraďte novým

K tomu druhému zadaní by bylo lepší taky zaslat dva sešity abych lépe pochopil zadání.

Option Explicit

Sub KopirujDataPredoslehoMesiaca()
Dim aktMesiac As Integer
Dim predMesiac As String
Dim nazvyMesiacov As Variant
Dim aktRok As Long, predRok As Long
Dim cesta As String, nzvPredZositu As String
Dim aktZosit As Workbook, predZosit As Workbook
Dim aktHarok As Worksheet, predHarok As Worksheet

nazvyMesiacov = Array("január", "február", "marec", "apríl", "máj", "jún", "júl", "august", "september", "október", "november", "december")

'reset mesiaca
aktMesiac = -1

' Získaj aktuálny Zošit a Hárok
Set aktZosit = ThisWorkbook
Set aktHarok = aktZosit.Sheets("Hárok2")

If aktHarok.Range("D2").Value = "" Then
MsgBox "Bunka D2:E2 je prázdná, doplnte mesiac do danej bunky"
Exit Sub
End If

' Získaj aktuálny mesiac a rok z názvu súboru
On Error Resume Next
aktMesiac = Application.Match(LCase(aktHarok.Range("D2").Value), nazvyMesiacov, 0)

If aktMesiac = -1 Then
MsgBox "Hľadaný mesiac v bunke D2:E2 """ & aktHarok.Range("D2").Value & """, je nesprávne napísaný. upravte text mesiaca."
Exit Sub
End If
aktRok = Replace(aktHarok.Range("F2").Value, "/", "")
On Error GoTo 0
If aktHarok.Range("F2").Value = "" Or aktRok = 0 Then
MsgBox "Hľadaný rok v bunke F2 """ & aktHarok.Range("F2").Value & """, je buď prázdná, alebo neobsahuje číslo roku. upravte text roku."
Exit Sub
End If
' Nastav predchádzajúci mesiac a rok

If aktMesiac = 1 Then
predMesiac = nazvyMesiacov(11)
predRok = aktRok - 1
Else
predMesiac = nazvyMesiacov(aktMesiac - 2)
predRok = aktRok
End If

nzvPredZositu = "Súhrn " & predMesiac & " " & predRok

' Nastav predpokladané prípony súborov
Dim nalezSuboru As Boolean
Dim pripona As Variant, pripony As Variant

pripony = Array(".xlsx", ".xls", ".xlsm")
nalezSuboru = False

' Skontroluj každú príponu súboru

For Each pripona In pripony
cesta = aktZosit.Path & "\" & nzvPredZositu & pripona
If Dir(cesta) <> "" Then
nalezSuboru = True
Exit For
End If
Next pripona

If Not nalezSuboru Then
MsgBox "Predchádzajúci súbor neexistuje alebo cesta nie je správna: " & aktZosit.Path & "\" & nzvPredZositu
Exit Sub
End If
' Vypnutie preblikávania obrazovky
Application.ScreenUpdating = False

' Otvor predchádzajúci Zošit
Set predZosit = Workbooks.Open(cesta)

' Nastav predchádzajúci sheet
Set predHarok = predZosit.Sheets("Hárok1")

' Skopíruj údaje z predchádzajúceho sheetu do aktuálneho
aktHarok.Range("C13:N13").Value = Application.Transpose(predHarok.Range("C10:C21").Value)

' Zatvor predchádzajúci workbook bez uloženia zmien
predZosit.Close SaveChanges:=False
Application.ScreenUpdating = True

MsgBox "Údaje boli úspešne skopírované z " & nzvPredZositu
End Sub

Dobrý den,

bylo by dobré zaslat přílohu, a ještě dotaz: má se hledat jenom první hodnota před "x" nebo i za "x"?

Dobrý den,
zasílám upravené makro.
Nahoře v modulu je Vaše původní, a pod ním to upravené makro.

Dobrý den,
vložte do modulu ve VBA Editoru tento kód níže. Podmínkou pro funkčnost makra je, aby všechny sešity byly ve stejné složce, a aby se jména listů (hárkov) jmenovali stejně jak máte v popisku a to "Hárok1" a "Hárok2"

Sub KopirujDataPredoslehoMesiaca()
Dim nazvyMesiacov As Variant
Dim aktZosit As Workbook, predZosit As Workbook
Dim aktHarok As Worksheet, predHarok As Worksheet
Dim aktMesiac As String, predMesiac As String
Dim aktRok As String, predRok As String
Dim cesta As String, nzvPredZositu As String

nazvyMesiacov = Array(" január ", " február ", " marec ", " apríl ", " máj ", " jún ", " júl ", " august ", " september ", " október ", " november ", " december ")

' Získaj aktuálny Zošit a Hárok
Set aktZosit = ThisWorkbook
Set aktHarok = aktZosit.Sheets("Hárok2")

' Získaj aktuálny mesiac a rok z názvu súboru
aktMesiac = Month(Date)
aktRok = Year(Date)

' Nastav predchádzajúci mesiac a rok
If aktMesiac = 1 Then
predMesiac = nazvyMesiacov(11)
predRok = aktRok - 1
Else
predMesiac = nazvyMesiacov(aktMesiac - 2)
predRok = aktRok
End If

nzvPredZositu = "Súhrn" & predMesiac & predRok

' Nastav predpokladané prípony súborov
Dim pripona As Variant, pripony As Variant
pripony = Array(".xlsx", ".xls", ".xlsm")

Dim nalezSuboru As Boolean
nalezSuboru = False

' Skontroluj každú príponu súboru
For Each pripona In pripony
cesta = aktZosit.Path & "\" & nzvPredZositu & pripona
If Dir(cesta) <> "" Then
nalezSuboru = True
Exit For
End If
Next pripona

If Not nalezSuboru Then
MsgBox "Predchádzajúci súbor neexistuje alebo cesta nie je správna: " & aktZosit.Path & "\" & nzvPredZositu
Exit Sub
End If

' Otvor predchádzajúci Zošit
Set predZosit = Workbooks.Open(cesta)

' Nastav predchádzajúci sheet
Set predHarok = predZosit.Sheets("Hárok1")

' Skopíruj údaje z predchádzajúceho sheetu do aktuálneho
aktHarok.Range("C13:N13").Value = Application.Transpose(predHarok.Range("C10:C21").Value)

' Zatvor predchádzajúci workbook bez uloženia zmien
predZosit.Close SaveChanges:=False

MsgBox "Údaje boli úspešne skopírované z " & nzvPredZositu

End Sub

Dobrý den, zkuste tohle:

1. Stáhnete soubor ""RychlaTlac.7z z přílohy.
2. Otevřete Excel, kde máte ty tabulky.
3. Stisknutím kláv. zkratky Alt + F11 otevřete VBA editor.
4. Vložte modul "RychlaTlac.bas" přes : File> Import File... (nebo kláv zkratka Ctrl+M).
5. Vyberte stažený soubor "RychlaTlac.bas"(soubor který jste si stáhla ode mně):
6. Mělo by se ve VBA editoru zobrazit v pravém horním rohu složka "Modules" a v něm soubor "RychlaTlac"
7. Dvojklikem otevřete tento modul. Skoro dole hledejte text ' Nastavte hárok, kde sa nachází tabulky
Set ws = ThisWorkbook.Sheets("Hárok1") ' místo "Hárok1" zadat skutočný názov hárku kde dle instrukce změňte název hárku dle vašeho pojmenování hárku.
8. Dále ve VBA editoru dvojkliknout v právem horním rohu na "ThisWorkbook" a vložit tento příkaz: Private Sub Workbook_Open()
PridejKontextMenu
End Sub

9. Uložte změny v Excelu
10. Zavřete, následně znovu otevřete Excel soubor s tabulkami
11. Nyní pravým tlačítkem myši by se mělo zobrazit kontextové menu pro tisk tabulek, na kterou když kliknete vyleze inputbox kam zadáte množství kopií a potvrdíte tlačítkem "OK" a hned proběhne tisk.

Ahoj,

zkus tohle:

Sub TiskVybraneTabulky()
Dim ws As Worksheet
Dim tabulka As String
Dim pctKopii As Integer

' Nastav list, kde se nachází tabulky
Set ws = ThisWorkbook.Sheets("Print")

' Výběr tabulky a počet kopií
tabulka = InputBox("Zadejte číslo tabulky k tisku (1 pro tabulku B134:M266, 2 pro tabulku R80:AD127):", "Výběr tabulky")
pctKopii = InputBox("Zadejte počet kopií:", "Počet kopií")

' Kontrola platnosti vstupů
If (tabulka <> "1" And tabulka <> "2") Or Not IsNumeric(pctKopii) Or pctKopii < 1 Then
MsgBox "Neplatný vstup. Prosím zkuste to znovu."
Exit Sub
End If

' Nastavení oblasti tisku podle výběru
Select Case tabulka
Case "1"
ws.PageSetup.PrintArea = "$B$134:$M$266"
Case "2"
ws.PageSetup.PrintArea = "$R$80:$AD$127"
End Select

' Tisk vybrané oblasti s požadovaným počtem kopií
ws.PrintOut Copies:=pctKopii
End Sub

Ahoj, upraveno

dobrý den,
snad jsem pochopil zadání viz přílohu

dobrý den, třeba takto.
Private Sub CommandButton1_Click()

'Updated by Extendoffice 2017/9/14
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String

Dim rng As Range
Dim obsah As String
Dim radek As Integer, sloupec As Integer

On Error Resume Next
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)

Set rng = UsedRange
For radek = 1 To rng.Rows.Count
For sloupec = 1 To rng.Columns.Count
obsah = obsah & " " & rng.Cells(radek, sloupec).Value
Next
obsah = obsah & vbNewLine
Next

xMailBody = "Body content" & vbNewLine & vbNewLine & _
"Copy from excel sheet" & vbNewLine & vbNewLine & obsah

On Error Resume Next
With xOutMail
.To = "test@seznam.cz"
.CC = ""
.BCC = ""
.Subject = "Test email send by button clicking"
.Body = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set rng = Nothing
Set xOutMail = Nothing
Set xOutApp = Nothing

End Sub

poslal jsem Vám vzkaz

poslal jsem Vám vzkaz.

Příspěvky uživatele

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje