Vytvorenie makra VBA na archivaciu Sheetov Vyřešeno

[cmuch]

Takže to musí být takto aby to fungovalo tak jak si představuješ.
Jedno makro musíš dát do ThisWorkBook, které zajištuje to že po otevření sešitu se otevře vždy vybraný list,
nesmí být stejný s tím na kterém je tl. uložit !!

Kód: Vybrat vše

Private Sub Workbook_Open()
  Sheets("ZOZNAM_checkre").Select
End Sub


Další musí být na každém listu co je tl. uložit

Kód: Vybrat vše

Private Sub Worksheet_Activate()
  Range("A1").Value = "1"
End Sub

A nyní je makro pro tl.

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 Long
Dim ValueQuantity As Integer
Dim X As Byte

Slozka = "reporty_databáza"
Rok = Year(Now())
Mesic = Month(Now())
Den = Day(Now())
AShNm = ActiveSheet.Name
ValueQuantity = ActiveSheet.Range("L7")
X = Range("A1").Value

'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
       
       'ulozi bez ohlaseni chyby na panelu
       Application.DisplayAlerts = False
       ActiveWorkbook.Close True
       Application.DisplayAlerts = 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
       'ulozi bez ohlaseni chyby na panelu
       Application.DisplayAlerts = False
       ActiveWorkbook.Close True
       Application.DisplayAlerts = 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"
       
    'jake bude pozadi na zaklade L7
    If ValueQuantity <= 1000 Then
        If Range("h" & FrstEmptyRow - X).Interior.ColorIndex = 20 Then
           
            Range("a" & FrstEmptyRow & ":h" & FrstEmptyRow).Interior.ColorIndex = 14 'modre jine pozadi
          Else
         
            Range("a" & FrstEmptyRow & ":h" & FrstEmptyRow).Interior.ColorIndex = 20 'modre pozadi
        End If
        If Workbooks("forma reportov_GEN_USB.xlsm").Sheets(AShNm).Range("A1").Value = 1 Then
            Workbooks("forma reportov_GEN_USB.xlsm").Sheets(AShNm).Range("A1").Value = "1"
            GoTo konec
        End If
       
      ElseIf ValueQuantity > 1000 And ValueQuantity < 3000 Then
        If Range("h" & FrstEmptyRow - X).Interior.ColorIndex = 6 Then
           
            Range("a" & FrstEmptyRow & ":h" & FrstEmptyRow).Interior.ColorIndex = 36 'zlute jine pozadi
          Else
         
            Range("a" & FrstEmptyRow & ":h" & FrstEmptyRow).Interior.ColorIndex = 6 'zlute pozadi
        End If
        If Workbooks("forma reportov_GEN_USB.xlsm").Sheets(AShNm).Range("A1").Value = 2 Then
            Workbooks("forma reportov_GEN_USB.xlsm").Sheets(AShNm).Range("A1").Value = "1"
            GoTo konec
        End If
        Workbooks("forma reportov_GEN_USB.xlsm").Sheets(AShNm).Range("A1").Value = X + 1
       
      ElseIf ValueQuantity >= 3000 Then
        If Range("h" & FrstEmptyRow - X).Interior.ColorIndex = 45 Then
           
            Range("a" & FrstEmptyRow & ":h" & FrstEmptyRow).Interior.ColorIndex = 46 'oranz. jine pozadi
          Else
           
            Range("a" & FrstEmptyRow & ":h" & FrstEmptyRow).Interior.ColorIndex = 45 'oranz. pozadi
        End If
        If Workbooks("forma reportov_GEN_USB.xlsm").Sheets(AShNm).Range("A1").Value = 3 Then
            Workbooks("forma reportov_GEN_USB.xlsm").Sheets(AShNm).Range("A1").Value = "1"
            GoTo konec
        End If
        Workbooks("forma reportov_GEN_USB.xlsm").Sheets(AShNm).Range("A1").Value = X + 1
    End If
       
konec:

    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


Tak odzkoušej.

[Reklama]

[mirek443_za]

Ahoj..
Skúšal som...a je to uplne super... presne podľa mojich predstáv..funguje perfektne...
ĎAKUJEM za tvoj čas a ochotu,si borec...