Stránka 1 z 1
Kopírování celého řádku mezi listy
Napsal: 26 zář 2012 13:23
od luko02420
Zdravím lidičky opět bych potřeboval poradit s automatickým kopírováním řádků mezi listy
př. na listu1 v buňce A5 bude zápis např. "j" v buňce A6 zápis "b" oba dva zápisy se budou nepravidelně opakovat já bych potřevoval kopírovat celé řádky které budou obsahovat ve sloupci A "j" na list "j" nebo "b" na list se stejným označením. atd zápis bude jenom na listě "1". nevím jestli by to nějak šlo udělat. Díky všem za radu
Re: Kopírování celého řádku mezi listy
Napsal: 26 zář 2012 20:49
od cmuch
Udělat to půjde.
To kopírování se bude spouštět čím? Tlačítkem nebo samo po vyplnění určitých sloupců?
Může být použit nějaký sloupec jako pomocný s informací, že už bylo jednou přeneseno?
Re: Kopírování celého řádku mezi listy
Napsal: 27 zář 2012 04:46
od luko02420
Mohlo by se to spouštět samo po vylnění sloupce "A" na listě 1bylo by to mozna i lepsi a pomocný sloupec by mohl být ale pokud to pujde tak na liste na který se to bude přenášet ale pokud by to nešlo ta i na tom prvním
Re: Kopírování celého řádku mezi listy
Napsal: 27 zář 2012 18:01
od cmuch
Makro se spouští samo po změně ve sloupci.
Veškeré nastavení je v makru.
Re: Kopírování celého řádku mezi listy
Napsal: 27 zář 2012 20:51
od luko02420
Díky moc to je přesně to co jsem potřeboval akorát me chvili trvalo nez jsem dosel na to ze musim prvni vyplnit data v radku a potom prvni sloupec jeste jednou diky.
Jeste jedna malickost potreboval bych toto makro prenest do jineho souboru ktery uz ma na liste makro, prejmenovani a nastaveni cest jsem jsi upravil ale nevim co vsechno mam prekopirovat je me jasne ze ten zacatek druhyho makra bude spatne. Diky moc a omlouvam se za vymysleni.
Kód: Vybrat vše
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Oblast As Range
Dim puvodnivyber As Variant
'definice sledované oblasti
Set Oblast = Range("E5:E200")
'test výběru
If Union(Oblast, Target).Address = Oblast.Address Then
Application.ScreenUpdating = False 'zakazani updatovani stranky
puvodnivyber = Target.Address 'zaznamenani posledni vybrane bunky
ActiveWindow.FreezePanes = False 'vypnuti ukotveni pricky
Range("E5:E200").Copy
Sheets("Efektivita zákazníků").Range("A2:A200").PasteSpecial
Application.CutCopyMode = False
With Sheets("Efektivita zákazníků")
.Range("A2:A200").RemoveDuplicates Columns:=1, Header:=xlNo
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:= _
Range("A2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange Range("A2:A197")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
'Range("E1").Select
End If
'definice sledované oblasti
Set Oblast = Range("E5:E200")
'test výběru
If Union(Oblast, Target).Address = Oblast.Address Then
Rows("10:10").Select 'vybrani radku od ktereho bude fungovat ukotveni pricky
ActiveWindow.FreezePanes = True 'zapnuti ukotveni pricky
Range(puvodnivyber).Select 'navrat na posledni vybranou bunku
Application.ScreenUpdating = True 'zapnuti updatovani stranky
End If
End Sub
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim prac, slprac, slpotvr, prj1, prj2, prj3 As Variant
Dim rprac, radek As Long
'Tichy rezim
Application.ScreenUpdating = False
'Nastaveni
prac = "List1" ' Název Listu ze ktereho se ma kopirovat
slprac = 1 ' Sloupec co se má kontrolvat , 1=A
slpotvr = 10 ' Sloupec do ktereho se bude zapisovat potvrzeni, 10=J
prj1 = "j" ' Jmeno listu i projektu 1
prj2 = "b" ' Jmeno listu i projektu 2
prj3 = "f" ' Jmeno listu i projektu 3
rprac = Target.Row ' Radek na kterem probehla zmena
' Proved kdyz je zmena ve sloupci
If Target.Column = slprac Then
' kontrola nazvu pokud nebylo jiz zkopirovano
If Not Cells(rprac, slprac).Value = "*" Then
Application.EnableEvents = False
If Cells(rprac, slprac).Value = prj1 Then
'Najít první volný řádek na listu a vlozit
radek = Sheets(prj1).Cells(Rows.Count, 1).End(xlUp).Row + 1
Worksheets(prac).Rows(rprac).Copy Destination:=Worksheets(prj1).Rows(radek)
Worksheets(prac).Cells(rprac, slpotvr) = "*"
ElseIf Cells(rprac, slprac) = prj2 Then
'Najít první volný řádek na listu a vlozit
radek = Sheets(prj2).Cells(Rows.Count, 1).End(xlUp).Row + 1
Worksheets(prac).Rows(rprac).Copy Destination:=Worksheets(prj2).Rows(radek)
Worksheets(prac).Cells(rprac, slpotvr) = "*"
ElseIf Cells(rprac, slprac) = prj3 Then
'Najít první volný řádek na listu a vlozit
radek = Sheets(prj3).Cells(Rows.Count, 1).End(xlUp).Row + 1
Worksheets(prac).Rows(rprac).Copy Destination:=Worksheets(prj3).Rows(radek)
Worksheets(prac).Cells(rprac, slpotvr) = "*"
Else
MsgBox "Neshoduje se název, zkontrolujte.", vbCritical
End If
Application.EnableEvents = True
End If
End If
'Tichy rezim vypnout
Application.ScreenUpdating = True
End Sub
Re: Kopírování celého řádku mezi listy
Napsal: 28 zář 2012 11:05
od cmuch
Spojil bych to takto:
Kód: Vybrat vše
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Oblast As Range
Dim puvodnivyber As Variant
'definice sledované oblasti
Set Oblast = Range("E5:E200")
'test výběru
If Union(Oblast, Target).Address = Oblast.Address Then
Application.ScreenUpdating = False 'zakazani updatovani stranky
puvodnivyber = Target.Address 'zaznamenani posledni vybrane bunky
ActiveWindow.FreezePanes = False 'vypnuti ukotveni pricky
Range("E5:E200").Copy
Sheets("Efektivita zákazníků").Range("A2:A200").PasteSpecial
Application.CutCopyMode = False
With Sheets("Efektivita zákazníků")
.Range("A2:A200").RemoveDuplicates Columns:=1, Header:=xlNo
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:= _
Range("A2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange Range("A2:A197")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
'Range("E1").Select
Rows("10:10").Select 'vybrani radku od ktereho bude fungovat ukotveni pricky
ActiveWindow.FreezePanes = True 'zapnuti ukotveni pricky
Range(puvodnivyber).Select 'navrat na posledni vybranou bunku
Application.ScreenUpdating = True 'zapnuti updatovani stranky
End If
Dim prac, slprac, slpotvr, prj1, prj2, prj3 As Variant
Dim rprac, radek As Long
'Tichy rezim
Application.ScreenUpdating = False
'Nastaveni
prac = "List1" ' Název Listu ze ktereho se ma kopirovat
slprac = 1 ' Sloupec co se má kontrolvat , 1=A
slpotvr = 10 ' Sloupec do ktereho se bude zapisovat potvrzeni, 10=J
prj1 = "j" ' Jmeno listu i projektu 1
prj2 = "b" ' Jmeno listu i projektu 2
prj3 = "f" ' Jmeno listu i projektu 3
rprac = Target.Row ' Radek na kterem probehla zmena
' Proved kdyz je zmena ve sloupci
If Target.Column = slprac Then
' kontrola nazvu pokud nebylo jiz zkopirovano
If Not Cells(rprac, slprac).Value = "*" Then
Application.EnableEvents = False
If Cells(rprac, slprac).Value = prj1 Then
'Najít první volný řádek na listu a vlozit
radek = Sheets(prj1).Cells(Rows.Count, 1).End(xlUp).Row + 1
Worksheets(prac).Rows(rprac).Copy Destination:=Worksheets(prj1).Rows(radek)
Worksheets(prac).Cells(rprac, slpotvr) = "*"
ElseIf Cells(rprac, slprac) = prj2 Then
'Najít první volný řádek na listu a vlozit
radek = Sheets(prj2).Cells(Rows.Count, 1).End(xlUp).Row + 1
Worksheets(prac).Rows(rprac).Copy Destination:=Worksheets(prj2).Rows(radek)
Worksheets(prac).Cells(rprac, slpotvr) = "*"
ElseIf Cells(rprac, slprac) = prj3 Then
'Najít první volný řádek na listu a vlozit
radek = Sheets(prj3).Cells(Rows.Count, 1).End(xlUp).Row + 1
Worksheets(prac).Rows(rprac).Copy Destination:=Worksheets(prj3).Rows(radek)
Worksheets(prac).Cells(rprac, slpotvr) = "*"
Else
MsgBox "Neshoduje se název, zkontrolujte.", vbCritical
End If
Application.EnableEvents = True
End If
End If
'Tichy rezim vypnout
Application.ScreenUpdating = True
End Sub
Re: Kopírování celého řádku mezi listy Vyřešeno
Napsal: 28 zář 2012 12:02
od luko02420
Díky zkusím a jenom pro info pokud zmením nazev listu tak to musím pomenit i v makro vsechny vyskyty daneho nazvu listu. Je to tak Jinak diky moc a snad se mi to podari rozjed.
--- Doplnění předchozího příspěvku (28 Zář 2012 12:32) ---
Díky moc už to chodí jak má