Vytvorenie makra VBA na archivaciu Sheetov Vyřešeno

[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..

[Reklama]

[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.

[mirek443_za]

aj tak dakujem..snad sa niekto najde....:)

[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.

[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...

[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..

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

---

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

[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á.

[mirek443_za]

Dakujem ti ..viem ze to robis na ukor svojho volneho casu a to si vazim...

[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.

[mirek443_za]

Si borec funguje to úplne perfektne...výborne odvedená práca... ..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!!!!!

[cmuch]

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"?

[mirek443_za]

Ano.. presne tam by to stacilo aby som vedel rozlisit,ze co ku sebe patri....