Vytvorenie makra VBA na archivaciu Sheetov Vyřešeno

[cmuch]

Tak asi takto (nahradit původní):

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, RCopy As Integer

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

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

znovu:

    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
        GoTo konec
       
      ElseIf ValueQuantity > 1000 And ValueQuantity < 3000 Then
        Range("a" & FrstEmptyRow & ":h" & FrstEmptyRow).Interior.Color = 65535 'zlute pozadi
        If RCopy = 2 Then GoTo konec
        RCopy = RCopy + 1
        GoTo znovu
       
      ElseIf ValueQuantity >= 3000 Then
        Range("a" & FrstEmptyRow & ":h" & FrstEmptyRow).Interior.Color = 39423 'oranz. pozadi
        If RCopy = 3 Then GoTo konec
        RCopy = RCopy + 1
        GoTo znovu
    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


[Reklama]

[mirek443_za]

Ahoj..no tak konecne som sa dostal k tomu aby som to vyskusal..
Vyzera to dobre len som prisiel nato,ze pri ukladani reportu mi do suboru reporty.xlsx automaticky nakopiruje podla poctu quantity naraz 2 lebo 3 zaznami, pricom hypertextovy odkaz v tychto zaznamoch odkazuje na ten isty list a to je pre mna nepouzitelne..pretoze ja budem mat sice rovnake datumi aj quantity na niektorych listoch ale budu tam ine hodnoty v meraniach.Na nete som nasiel a poupravil tento kod len neviem,ako tam este vlozit podmienku aby sa riadky oznacovali tak,ze ak sa nachadzaju pod sebou zaznami 2 reporov s quantity nad 1000 resp. 3000 ks to je 4 resp 6 riadkov..tak aby riadky patriace k tomu dalsiemu reportu oznacilo napr inym odtienom tej istej farby...dufam ze som to moc neskomplikoval..
'farba buniek podla podmienky v zosite reporty.xlsx
'
Windows("reporty.xlsx").Activate

Dim riad As Integer, priad As Integer
Dim pstl As Integer
Dim x As Variant
For x = 1000 To 3000
Application.ScreenUpdating = False
Set oblast = ActiveSheet.UsedRange
' oblasť ohraničená neprázdnymi bunkami
oblast.Select
pstl = Selection.Columns.Count
' Počet stĺpcov v oblasti
priad = Selection.Rows.Count
' Počet riadkov v oblast
Debug.Print priad, pstl
' zapíšeme do pohotovostného okna (immediate window)
' koľko máme v oblasti riadkov a stĺpcov
' len pre kontrolu - môžeme "Debug.Print priad, pstl" zmazať

For riad = 3 To priad
If Cells(riad, 5).Value = x Then _
Application.Cells(riad, 5).Interior.Color _
= RGB(255, 204, 153)
If Cells(riad, 5).Value < 1000 Then _
Application.Cells(riad, 5).Interior.Color _
= RGB(255, 204, 0)
If Cells(riad, 5).Value > 3000 Then _
Application.Cells(riad, 5).Interior.Color _
= RGB(153, 204, 0)


Next riad
Next x

[cmuch]

Tady je dalsi vylepsení, je teda na jinem principu nez mas ty.
Ale vyzkousej.

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, RCopy, X As Integer

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

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

znovu:

    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
        GoTo konec
 
      ElseIf ValueQuantity > 1000 And ValueQuantity < 3000 Then
        If Range("h" & FrstEmptyRow - X).Interior.ColorIndex = 6 Then
            X = X + 1
            Range("a" & FrstEmptyRow & ":h" & FrstEmptyRow).Interior.ColorIndex = 36 'zlute jine pozadi
          Else
            X = X + 1
            Range("a" & FrstEmptyRow & ":h" & FrstEmptyRow).Interior.ColorIndex = 6 'zlute pozadi
        End If
        If RCopy = 2 Then GoTo konec
        RCopy = RCopy + 1
        GoTo znovu
      ElseIf ValueQuantity >= 3000 Then
        If Range("h" & FrstEmptyRow - X).Interior.ColorIndex = 45 Then
            X = X + 1
            Range("a" & FrstEmptyRow & ":h" & FrstEmptyRow).Interior.ColorIndex = 46 'oranz. jine pozadi
          Else
            X = X + 1
            Range("a" & FrstEmptyRow & ":h" & FrstEmptyRow).Interior.ColorIndex = 45 'oranz. pozadi
        End If
        If RCopy = 3 Then GoTo konec
        RCopy = RCopy + 1
        GoTo znovu
    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


Změna proběhla mezi 'jake bude pozadi na zaklade L7 a konec:

[mirek443_za]

Presne takto nejako farebne som si to predstavoval ,len este stale mi to vytvara v subore reporty.xlsx, ked dam report ulozit, naraz 2 alebo 3 zaznami..napr report nad 3000 ukladam 3x ale v subore reporty.xlsx mam namiesto 3 riadkov 9 riadkov... cize kazdy riadok sa duplikuje podla velkosti quantity..

[cmuch]

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

Dělal jsem to dle tohoto. Tak ještě jednou vysvětli.

len este stale mi to vytvara v subore reporty.xlsx, ked dam report ulozit, naraz 2 alebo 3 zaznami..napr report nad 3000 ukladam 3x ale v subore reporty.xlsx mam namiesto 3 riadkov 9 riadkov...

Nebo to mám chápat tak, že reporty jsou dělány pokaždé z jiného listu a řádky mají být po jednom ale jen barevně od sebe odlišeny?

[mirek443_za]

tak ešte raz to pokúsim vysvetliť.. :)
Mám na reporte tlačitko uložiť s priradeným makrom od teba.
Urobim merania ktoré sú v spodnej čati reportu a kliknem uložiť
V subore reporty.xlsx by mi malo urobit jeden zápis (riadok).
ak má report quantity >1000 > 3000 prepisem hodnoty v meraniach na tom istom reporte (bunky ako datum,quantity,part No.....sa nemenia) znova kliknem na uložiť
v reporty.xlsx mi zapiše další riadok .
na 1 report robim bud 1,2 alebo max3 merania podľa quantity.
farebné rozlišenie ako je doteraz je super,presne tak to chcem,len ked kliknem uložiť,vždy by mi malo zapisat do reporty.xlsx len jeden riadok.
nakoniec podla quantity by mala byt podmienka ze jednou farbou označí bud 1,2,alebo 3 riadky.

može nastať aj prípad, že robim po sebe 2 alebo viac reportov s rovnakým dátumom aj quantity.
napr.robim 2 reporty s quantity 3200 a dátumom 4.6.2012
v reporty.xlsx to bude 6 rovnakých riadkov, pričom k jednemu reportu patria len 3 (jednou farbou) a tie dalsie 3 už inou farbou..
takýto pripad može nastať aj s quantity >1000<3000 alebo <1000

Na 1 report sú max 3 riadky a kolko ich skutočne bude záleží od quantity..
prepáč za nedostatočné vysvetlenie, snaď už je to lepšie.. :)

[cmuch]

Nič sa nedeje
Tak asi teda takto:

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

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

'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"
       
    'jake bude pozadi na zaklade L7
    If ValueQuantity <= 1000 Then
        GoTo konec
 
      ElseIf ValueQuantity > 1000 And ValueQuantity < 3000 Then
        If Range("h" & FrstEmptyRow - 1).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
      ElseIf ValueQuantity >= 3000 Then
        If Range("h" & FrstEmptyRow - 1).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
    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


[mirek443_za]

no uz sme zasa kustik blizsie..:) prikladam obrazok ako by to malo byt...
QUANTITY: <1000 - 1 REPORT - 1 ZAPIS (RIADOK) - 1 FARBA
>1000<3000 - 1 REPORT - 2 ZAPISY (RIADKY) - 1 FARBA
>3000 - 1 REPORT - 3 ZAPISY (RIADKY) - 1 FARBA

[cmuch]

Takže na to tlačítko na tom listu se bude mačkat 1, 2, 3x podle hodnoty Quantity?
A v reporty.xlsx budou 1, 2, 3 řádky stejné barvy?

Pokud to teď chápu dobře, tak se bude muset trochu předělat koncepce.

[mirek443_za]

aaano presne tak,teraz sme sa uz pochopili... :)

[cmuch]

Ještě dotaz.
Pro to vyexportování 1, 2, 3 kopii podle quantity se bude pořád na aktualnim listu nebo se bude mezitím různě překlikávat mezi listy?

[mirek443_za]

Bude to stale na tom istom liste..len merania v spodnej casti sa budu menit.. cize v podstate horna cast reportu ostane a spodna sa zmeni na kazdej kopii v meraniach