Kopírovanie hodnôt Vyřešeno
Napsal: 03 čer 2013 19:57
od 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
Re: Kopírovanie hodnôt
Napsal: 04 čer 2013 05:58
od 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