Kopírování celého řádku mezi listy Vyřešeno

[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

[Reklama]

[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?

[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

[cmuch]

Makro se spouští samo po změně ve sloupci.
Veškeré nastavení je v makru.

[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

[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


[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á