Kopírovanie hodnôt Vyřešeno

[merry]

Dobrý večer, potrebovala by som pomôcť s makrom.

V priloženom súbore by som potrebovala kopírovať hodnoty z ostatných listov do listu sumár, ak v nejakom liste v stĺpci C alebo J zadám hodnotu vyššiu než 0, tak sa prekopírujú hodnoty A-F alebo H-M do listu sumár. A tiež by bolo dobré aby to fungovalo aj po pridaní ďalších listov.

Ďakujem za pomoc

[Reklama]

[cmuch]

Toto makro nakopíruj do ThisWorkBook

Kód: Vybrat vše

 Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

      Dim prac As Variant
      Dim slprac1, slprac2 As Integer
      Dim rprac, radek As Long

      'Nastaveni
      prac = "Sumár"  ' Název Listu do ktereho se ma kopírovat
      slprac1 = 3      ' Sloupec co se má kontrolvat , 1=A
      slprac2 = 10      ' Sloupec co se má kontrolvat , 1=A
     
      rprac = Target.Row    ' Radek na kterem probehla zmena
     
      ' Neprovadej na listu do ktereho se ma kopirovat
      If ActiveSheet.Name = prac Then Exit Sub
       
        'Tichy rezim
        Application.ScreenUpdating = False
        Application.EnableEvents = False
       
        ' Proved kdyz je zmena ve sloupci
        If Target.Column = slprac1 Then
            ' kontrola zda se ma kopirovat
            If Cells(rprac, slprac1).Value > 0 Then
           
                'Najít první volný řádek na listu a vlozit
                radek = Sheets(prac).Cells(Rows.Count, 1).End(xlUp).Row + 1
                ActiveSheet.Range("A" & Target.Row & ":F" & Target.Row).Copy Destination:=Worksheets(prac).Range("A" & radek & ":F" & radek)
            End If
           
          ElseIf Target.Column = slprac2 Then
           
            ' kontrola zda se ma kopirovat
            If Cells(rprac, slprac2).Value > 0 Then
     
                'Najít první volný řádek na listu a vlozit
                radek = Sheets(prac).Cells(Rows.Count, 1).End(xlUp).Row + 1
                ActiveSheet.Range("H" & Target.Row & ":M" & Target.Row).Copy Destination:=Worksheets(prac).Range("A" & radek & ":F" & radek)
            End If
        End If
    'Tichy rezim vypnout
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub