PC-HELP.CZ

České diskuzní fórum o počítačích
https://pc-help.cnews.cz/

Vytvorenie makra VBA na archivaciu Sheetov

https://pc-help.cnews.cz/viewtopic.php?f=35&t=86600

Stránka 1 z 3

Vytvorenie makra VBA na archivaciu Sheetov

Napsal: 21 kvě 2012 11:39
od mirek443_za
Dobrý deň..Vedel by mi niekto prosím pomôcť s vytvorením VBA makra v EXCELY 2007? V priloženom zošite (sheety sa budú postupne dopĺňať), by bolo na každom sheete tlačítko pre jeho uloženie do nového zošita bez vzorcov, len s hodnotami vo formáte... c:\reporty_databáza\ActiveSheet.Name\ROK\MESIAC\ dátum_ActiveSheet.Name.xlsx.
Ak bude takýto zošit už existovať..sheety sa doplnia do neho. Všetky sheety sa budú do nového zošita ukladať pod názvom podľa hodnoty bunky L7.
Ak by sa v novom zošite už sheet s rovnakým názvom nachádzal, doplnilo by sa do názvu len číslo 1,2,3 atď...
Zároveň by sa vytváral zvlášť jeden zošit, v ktorom by sa zapisovali údaje zo všetkých uložených listov pod seba + automaticky by sa vytvoril HYPERTEXTOVÝ ODKAZ NA DANÝ LIST do tabuľky vo formáte:

DELIVERY DATE PART NO. PART NAME ECO NO. DELIVERED QUANTITY ARCHIV CHECKER HYPERTEXTOVÝ ODKAZ NA LIST
1. L6 F10 F9 L8 L7 F6 L9 VYTVORÍ SA
2.
3.

Som vo VBA úplný začiatočník, zatiaľ sa len učím a štýlom pokus omyl som sa za 2 týždne surfovania po webe nikam nedostal. Aj keď som dal čosi dokopy tak to nefunguje tak ako by malo.Bol by som Vám borci veľmi povďačný keby ste mi vedeli pomôcť, veľmi by ste mi uľahčili život..
Veľmi pekne ďakujem..

Re: Vytvorenie makra VBA na archivaciu SHEETOV

Napsal: 22 kvě 2012 01:17
od d1amond
Vítej na PC-HELP

Top. Nemám absolutně volnou chvilku - a tohle vyžaduje podstatně víc, ale třeba na to někdo koukne.

Re: Vytvorenie makra VBA na archivaciu SHEETOV

Napsal: 22 kvě 2012 09:04
od mirek443_za
aj tak dakujem..snad sa niekto najde....:)

Re: Vytvorenie makra VBA na archivaciu SHEETOV

Napsal: 23 kvě 2012 06:43
od cmuch
Ahoj,
tak jsem na to koukal a něco zkusil vytvořit.
Zatím je teda jen kopírování listů. Tak to vyzkoušej.
Je to zatím jen pro tl. v listu 28610-1K400 (A), pro ostatní listy stačí toto tlačítko rozkopírovat.

Re: Vytvorenie makra VBA na archivaciu SHEETOV

Napsal: 23 kvě 2012 07:27
od mirek443_za
Ahoj..
Noo skušal som,len zakaždým mi vyhodi "Neexistuje složka na C:\ nebo složka listu nebo rok."
Skušal som aj adresare celej cesty vytvorit manualne ale nepomohlo...:)

--- Doplnění předchozího příspěvku (23 Kvě 2012 07:36) ---

tak na druhý pokus som to nejako rozbehal..mal som chybu v názve zložky mesiac..namiesto slovného pomenovania trebalo číslo..:)
kopirovanie zatial funguje tak ako ma...

Re: Vytvorenie makra VBA na archivaciu Sheetov

Napsal: 24 kvě 2012 14:32
od mirek443_za
Pomohli by ste mi upravit ešte stávajúci kód aby mi vytvaralo aj zložku Názov listu + Rok + Mesiac automaticky a nie len vyhodilo hlašku,že zložka neexistuje??
je to len čast mojho problému ale aj tak by ma to posunulo kustik dalej.. :huh:

dakujem vsetkým,čo budú ochotný sa mi na to kuknút... :roll:


Kód: Vybrat vše

Option Explicit

Sub UlozList()
'
Dim strNazevOpen As Workbook
Dim strNazev As String
Dim strCesta As String
Dim fso As Object
Dim Rok, Mesiac, Deň As Variant


Rok = Year(Now())
Mesiac = Month(Now())
Deň = Day(Now())

'Vytvori nazov
strNazev = Deň & "_" & ActiveSheet.Name & ".xlsx"
'Vytvori cestu
strCesta = "c:\reporty_databáza\" & ActiveSheet.Name & "\" & Rok & "\" & Mesiac

Set fso = CreateObject("Scripting.FileSystemObject")
'Pokud složka název listu, rok neexistuje
 If fso.FolderExists(strCesta) = False Then

'Dim fs, objFolder
'Dim Cesta As Variant

'Cesta = ("c:\reporty_databáza\" & ActiveSheet.Name)
    'Set fs = CreateObject("Scripting.FileSystemObject")
    'If fs.FolderExists(Cesta) Then
   ' MsgBox "Už existuje"
   ' Else
    'Set objFolder = fs.createfolder(Cesta)
   
    'MsgBox "Už existuje"

    'MsgBox "Nová zložka pod názvom " & _
    'objFolder.Name & " bola vytvorená."

   MsgBox "Neexistuje zložka na C:\REPORTY_DATABÁZA alebo zložka listu,alebo rok."
   Set fso = Nothing
 
 Exit Sub
 End If

'Pokud složka mesice neexistuje, tak ju vytvoríme

If fso.FolderExists(strCesta) = False Then fso.createfolder (strCesta)

    'Kontrola, zda již ve složce není soubor stejného názvu
    If fso.FileExists(strCesta & "\" & strNazev) Then
       Set strNazevOpen = Workbooks.Open(strCesta & "\" & strNazev)
   
       Windows("forma reportov_GEN_USB_forum.xlsm").Activate
       ActiveSheet.Copy Before:=Workbooks(strNazev).Sheets(1)
       Cells.Select
       Selection.Copy
       Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
             :=False, Transpose:=False
       Application.CutCopyMode = False
       ActiveWorkbook.Close True

      Else
     
       Sheets(ActiveSheet.Name).Copy
       ActiveWorkbook.SaveAs Filename:= _
            strCesta & "\" & strNazev, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
       Cells.Select
       Selection.Copy
       Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
             :=False, Transpose:=False
       Application.CutCopyMode = False
       ActiveWorkbook.Close True
  End If
   
Windows("forma reportov_GEN_USB_forum.xlsm").Activate

Set fso = Nothing
'End If
End Sub

Re: Vytvorenie makra VBA na archivaciu Sheetov

Napsal: 24 kvě 2012 15:41
od cmuch
Tady je poupraven kod pro vytvoření těch složek a následná kopie listu.

Kód: Vybrat vše

Sub UlozList()
'
Dim strNazevOpen As Workbook
Dim strNazev As String
Dim strSlozka As String
Dim strSesit As String
Dim strRok As String
Dim strMesic As String
Dim strCesta As String
Dim Fso As Object
Dim Slozka, Rok, Mesic, Den As Variant

Slozka = "reporty_databáza"
Rok = Year(Now())
Mesic = Month(Now())
Den = Day(Now())

'Vytvori nazov budouciho sesitu
strNazev = Den & "_" & ActiveSheet.Name & ".xlsx"
'Vytvori cestu slozky
strSlozka = "c:\" & Slozka
'Vytvori cestu sesitu
strSesit = "c:\" & Slozka & "\" & ActiveSheet.Name
'Vytvori cestu roku
strRok = "c:\" & Slozka & "\" & ActiveSheet.Name & "\" & Rok
'Vytvori cestu mesice
strMesic = "c:\" & Slozka & "\" & ActiveSheet.Name & "\" & Rok & "\" & Mesic

Set Fso = CreateObject("Scripting.FileSystemObject")

'Pokud složka mesice neexistuje, tak ju vytvoríme
If Fso.FolderExists(strSlozka) = False Then Fso.CreateFolder (strSlozka)
'Pokud složka mesice neexistuje, tak ju vytvoríme
If Fso.FolderExists(strSesit) = False Then Fso.CreateFolder (strSesit)
'Pokud složka mesice neexistuje, tak ju vytvoríme
If Fso.FolderExists(strRok) = False Then Fso.CreateFolder (strRok)
'Pokud složka mesice neexistuje, tak ju vytvoríme
If Fso.FolderExists(strMesic) = False Then Fso.CreateFolder (strMesic)

    'Kontrola, zda již ve složce není soubor stejného názvu
    If Fso.FileExists(strMesic & "\" & strNazev) Then
   
       Set strNazevOpen = Workbooks.Open(strMesic & "\" & strNazev)
   
       Windows("forma reportov_GEN_USB.xlsm").Activate
       ActiveSheet.Copy Before:=Workbooks(strNazev).Sheets(1)
       Cells.Select
       Selection.Copy
       Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
             :=False, Transpose:=False
       Application.CutCopyMode = False
       ActiveWorkbook.Close True
 
      Else
     
       Sheets(ActiveSheet.Name).Copy
       ActiveWorkbook.SaveAs Filename:= _
            strMesic & "\" & strNazev, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
       Cells.Select
       Selection.Copy
       Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
             :=False, Transpose:=False
       Application.CutCopyMode = False
       ActiveWorkbook.Close True
 
    End If
   
Windows("forma reportov_GEN_USB.xlsm").Activate

Set Fso = Nothing
   
End Sub

Na tu druhou část se kouknu asi o víkendu pokud Ti to někdo nedodělá.

Re: Vytvorenie makra VBA na archivaciu Sheetov

Napsal: 24 kvě 2012 16:28
od mirek443_za
Dakujem ti ..viem ze to robis na ukor svojho volneho casu a to si vazim...

Re: Vytvorenie makra VBA na archivaciu Sheetov

Napsal: 27 kvě 2012 15:25
od cmuch
Tak jsem se dnes dostal k PC a něco vytvořil.

1. Je potřeba ve složce "reporty_databáza" vytvořit nový sešit "reporty.xlsx" ( lze změnit v makru )
2. Nahradit stávající makro tímto

Kód: Vybrat vše

Sub UlozList()
'
Dim strNazevOpen As Workbook
Dim strNazev As String
Dim strSlozka As String
Dim strSesit As String
Dim strRok As String
Dim strMesic As String
Dim strCesta As String
Dim Fso As Object
Dim Slozka, Rok, Mesic, Den, AShNm As Variant
Dim FrstEmptyRow As Variant

Slozka = "reporty_databáza"
Rok = Year(Now())
Mesic = Month(Now())
Den = Day(Now())
AShNm = ActiveSheet.Name

'Vytvori nazov budouciho sesitu
strNazev = Den & "_" & AShNm & ".xlsx"
'Vytvori cestu slozky
strSlozka = "c:\" & Slozka
'Vytvori cestu sesitu
strSesit = "c:\" & Slozka & "\" & AShNm
'Vytvori cestu roku
strRok = "c:\" & Slozka & "\" & AShNm & "\" & Rok
'Vytvori cestu mesice
strMesic = "c:\" & Slozka & "\" & AShNm & "\" & Rok & "\" & Mesic

Application.ScreenUpdating = False

Set Fso = CreateObject("Scripting.FileSystemObject")

'Pokud složka neexistuje, tak ju vytvoríme
If Fso.FolderExists(strSlozka) = False Then Fso.CreateFolder (strSlozka)
'Pokud složka sesitu neexistuje, tak ju vytvoríme
If Fso.FolderExists(strSesit) = False Then Fso.CreateFolder (strSesit)
'Pokud složka rok neexistuje, tak ju vytvoríme
If Fso.FolderExists(strRok) = False Then Fso.CreateFolder (strRok)
'Pokud složka mesice neexistuje, tak ju vytvoríme
If Fso.FolderExists(strMesic) = False Then Fso.CreateFolder (strMesic)

    'Kontrola, zda již ve složce není soubor stejného názvu
    If Fso.FileExists(strMesic & "\" & strNazev) Then
   
       Set strNazevOpen = Workbooks.Open(strMesic & "\" & strNazev)
   
       Windows("forma reportov_GEN_USB.xlsm").Activate
       ActiveSheet.Copy Before:=Workbooks(strNazev).Sheets(1)
       Cells.Select
       Selection.Copy
       Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
             :=False, Transpose:=False
       Application.CutCopyMode = False
       ActiveWorkbook.Close True
 
      Else
     
       Sheets(AShNm).Copy
       ActiveWorkbook.SaveAs Filename:= _
            strMesic & "\" & strNazev, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
       Cells.Select
       Selection.Copy
       Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
             :=False, Transpose:=False
       Application.CutCopyMode = False
       ActiveWorkbook.Close True
 
    End If

Set Fso = Nothing

'otevre sesit s reportama a nakopiruje tam hodnoty a vytvori hyp.odkaz
Workbooks.Open Filename:="C:\reporty_databáza\reporty.xlsx"
FrstEmptyRow = Cells(Rows.Count, 1).End(xlUp).Row + 1

    Windows("forma reportov_GEN_USB.xlsm").Activate
    Range("L6:N6").Copy
    Windows("reporty.xlsx").Activate
    Range("A" & FrstEmptyRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
       
    Windows("forma reportov_GEN_USB.xlsm").Activate
    Range("F10:I10").Copy
    Windows("reporty.xlsx").Activate
    Range("B" & FrstEmptyRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
       
    Windows("forma reportov_GEN_USB.xlsm").Activate
    Range("F9:I9").Copy
    Windows("reporty.xlsx").Activate
    Range("C" & FrstEmptyRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
       
    Windows("forma reportov_GEN_USB.xlsm").Activate
    Range("L8:N8").Copy
    Windows("reporty.xlsx").Activate
    Range("D" & FrstEmptyRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
       
    Windows("forma reportov_GEN_USB.xlsm").Activate
    Range("L7:N7").Copy
    Windows("reporty.xlsx").Activate
    Range("E" & FrstEmptyRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
       
    Windows("forma reportov_GEN_USB.xlsm").Activate
    Range("F6:I6").Copy
    Windows("reporty.xlsx").Activate
    Range("F" & FrstEmptyRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
       
    Windows("forma reportov_GEN_USB.xlsm").Activate
    Range("L9:N9").Copy
    Windows("reporty.xlsx").Activate
    Range("G" & FrstEmptyRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
       
    Application.CutCopyMode = False
    Range("H" & FrstEmptyRow).Select
   
    'vytvori hyp.odkaz
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
       strMesic & "\" & strNazev, TextToDisplay:="odkaz"
       
    Range("A1").Select
       
    'ulozi bez ohlaseni chyby na panelu
    Application.DisplayAlerts = False
    ActiveWorkbook.Close True
    Application.DisplayAlerts = True
   
    Application.ScreenUpdating = True
   
    MsgBox "List zkopirovan.", vbInformation
   
End Sub

3.V makru na konci je hlášení, když tak odstranit.

Re: Vytvorenie makra VBA na archivaciu Sheetov

Napsal: 28 kvě 2012 10:40
od mirek443_za
Si borec funguje to úplne perfektne...výborne odvedená práca... :smile: ..len už posledná vec chyba k dokonalosti..ak je v reporte quantity <1000 robim len 1 ak je 1000><3000 robim 2, a ak je nad 3000 robim 3 reporty s rovnakym datumom aj poctom. Chcem sa spytat ci nieje nejaka moznost ako to v subore reporty.xlsx odlisit napr farebne,ze patria k sebe 1,2,alebo 3 riadky pod sebou....ak nie tak nevadi..aj tak ti moc DAKUJEM za pomoc!!!!! :wink:

Re: Vytvorenie makra VBA na archivaciu Sheetov

Napsal: 28 kvě 2012 20:47
od cmuch
:wink:
Takže třeba takto by to vypadalo:

    <10001.........1 radek bez barvy
    1000><3000....2 radky třeba žlutě
    nad 3000.......3 radky třeba oranžově
Toto by probíhalo jen při kopírování do sešitu "reporty"?

Re: Vytvorenie makra VBA na archivaciu Sheetov

Napsal: 28 kvě 2012 21:07
od mirek443_za
Ano.. :wink: presne tam by to stacilo aby som vedel rozlisit,ze co ku sebe patri.... :smile:
Časové pásmo: UTC+02:00
Stránka 1 z 3
Powered by phpBB® Forum Software © phpBB Limited
https://www.phpbb.com/