< návrat zpět

MS Excel

Téma: kopirovanie s predosleho mesiaca rss

Zaslal/a ivana1 22.7.2024 22:07

Bol by niekto ochotny mi pomoct mam vzdy rovnake tabulky ulozene v pc ktore ukladam vzdy podla prislusneho mesiasa:
Súhrn mesiac rok.xlsm

Ked mam otvoreny nejaky mesiac tak do buniek C13:N13 na Harku2 potrebujem v pc najst zosit s predosleho mesiaca a vlozit udaje vzdy s Hárka1 s buniek C10:C21.

Toto potrebujem vzdy robit s kazdym mesiacom aby mi vlozilo udaje s predosleho mesiaca do aktualneho mesiaca.

Příloha: zip56688_suhrn-2024.zip (17kB, staženo 11x)
Zaslat odpověď >
Strana:  1 2   další »
€Ł мσşqμΐτσ(23.7.2024 8:06)#056689
€Ł мσşqμΐτσ
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 Subcitovat
ivana1(23.7.2024 19:25)#056701
avatar
Dakujem za ochotu len dostavam chybove hlasenie :Predchádzajúci súbor neexistuje alebo cesta nie je správna

Podla mna si to berie aktualny datum aky je momentalne . Ja potrebujem keby to bralo datum ktory je zadany na harku2 v D2 a E2 aby mohol napr nacitat aj starsie suhrny. Ked si napr otvorim september tak vzdy sa snazi brat udaje s juna.

Este by sa chcela opytat mam este podobny zosit zo suhrnom ktory pracuje na tom istom principe len namiesto harku1 mam harky znacene len ako cisla 1,2,3 atd a ja by potrebovala aby mi otvorilo predchadzajuci zosit a naslo vzdy posledny ciselny harok a s neho skopirovalo udaje do aktualneho mesiaca na harok 2citovat
€Ł мσşqμΐτσ(24.7.2024 8:49)#056703
€Ł мσşqμΐτσ
Dobrý den,
omlouvám se za špatně pochopené zadání. 8
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

citovat
ivana1(24.7.2024 19:29)#056705
avatar
Som vam vdacna zatial vsetko ide len este ak mozete sa mi pozriet na ten druhy suhrn princip je rovnaky len do aktualneho mesiaca potrebujem vlozit udaje s predosleho zosita vdzy len s posledneho ciselneho harka 1,2,3,4,5 (je ich max do 30) a hodnoty vlozit do aktualneho zosita na harok 2.
Příloha: zip56705_suhrn.zip (23kB, staženo 5x)
citovat
€Ł мσşqμΐτσ(25.7.2024 8:09)#056706
€Ł мσşqμΐτσ
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 Subcitovat
ivana1(25.7.2024 20:40)#056707
avatar
Dakujem ste zlaty. Mozem este poziadat jednu malickost.

Na harku suhrn mam tabulku a do tejto tabulky by potrebovala vkladat udaje s ciselnych harkov ak sa nachadzaju iba udaje v bunkchach E10:E21 + skopirovat datum s I5 a vlozit to do harka suhrn J23:Q45 podla poradia datumov. Ak sa nenachdzaju ziadne udaje tak ciselny harok preskocit.
Ak som zle napisla tak sa ospravedlnujem
Příloha: zip56707_suhrn-september-2024.zip (16kB, staženo 3x)
citovat
€Ł мσşqμΐτσ(26.7.2024 10:07)#056708
€Ł мσşqμΐτσ
Dobrý den.

přidáno nové makro v příloze
Příloha: zip56708_suhrn-september-2024.zip (31kB, staženo 8x)
citovat
ivana1(28.7.2024 21:07)#056709
avatar
Dakujem funguje to super len sa chcem ospravedlnit lze som zadala hodnoty vedeli by ste mi to este raz upravit. Ciselne harky maju rozsah E34:E48.

Suhrn:
Datum ma rozsah J59:Q59
import s ciselnych harkov J61:Q83citovat
€Ł мσşqμΐτσ(29.7.2024 8:53)#056710
€Ł мσşqμΐτσ
Dobrý den, upraveno.
Příloha: zip56710_suhrn-september-2024.zip (31kB, staženo 11x)
citovat
ivana1(29.7.2024 9:46)#056711
avatar
Veľmi pekne ďakujem ešte raz a ospravedlňujem že som vám dala druhú tabuľku mám ich takmer rovnaké.citovat

Strana:  1 2   další »

Uživatelské menu

Nejste přihlášen(a)
avatar\n

Menu

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.

On-line nástroje