pomoc s makrem v Excelu

[asanplasan]

zdravim, mohl by mi nekdo ochotny pomoci vytvorit makro: list 1, sloupec 1, radek 1 az x, vyber bunku, najdi totoznou na listu 2, kdyz najdes zkopiruj nektere bunky ze stejneho radku ( barevne rozliseno ) do listu 1 ( do stejne barevnych bunek ). a pokracuj, dokud jsou ve sloupci 1 data.

neco jsem udelal pomoci "zaznam makra" ale nejsem schopen ho donutit aby pokracoval vic jak jeden radek.
Diky za pomoc chytrejsich. Asanplasan
p.s. priloha se souborem

[navstevnik]

Upresni:
list1 v popisu pozadovaneho makra je v prilozenem sesitu list import na web, radek 1 je radek 7:7 na tomto listu?
list2 je list data, totozna bunka je ve sloupci A:A?
Na listu data nejsou ve sloupci A:A jakakoliv data odpovidajici list1, sloupce A:A.
Na list1 jsou od radku 344 nejaka data, jakou maji souvislost s pozadavkem?
Pripoj novou prilohu obsahujici pouze relevantni data.

[asanplasan]

se omlouvam, ale jak jsem zmensoval velikost souboru, tak jsem to promazal spatne.
Tak to posilam zpet a nechal jsem tam jenom tri radky na zkousku.
list1, sloupec A, bunka 2 az ... ,, a list 2, sloupec A, bunka 2 jsou ty od kud se hledaji a nachazeji, a z listu 2 do listu 1 se dle barev kopiruji nalezene bunky z prislusneho radku.
diky Ashan

[navstevnik]

Nize uvedena procedura vykona pozadovane (na listu1 odstran poznamky v A31:A36; hlavicky ve sloupcich A:A zustanou rozdilne jako v ukazce); vloz do standardniho modulu, volat napr. klavesovou zkratkou nebo z menu:

Kód: Vybrat vše

Option Explicit

Sub Dopln()
' deklarace promennych
  Dim SBlk As Range, SCll As Range
  Dim FBlk As Range, FCll As Range
  ' definice bloku ma listu 1
  With Worksheets("list1")
    Set SBlk = .Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
  End With
  ' definice bloku na listu 2
  With Worksheets("list2")
    Set FBlk = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
  End With
  ' ve smycce podle bunek v SBlk prohledavat FBlk
  For Each SCll In SBlk.Cells
    Set FCll = FBlk.Find(SCll.Value, LookIn:=xlValue, LookAt:=xlWhole)
    ' kdyz nalezeno, prenest pozadovana data
    If Not FCll Is Nothing Then
      With SCll
        .Offset(0, 4).Value = FCll.Offset(0, 2).Value
        .Offset(0, 6).Value = FCll.Offset(0, 10).Value
        .Offset(0, 11).Value = FCll.Offset(0, 15).Value
        .Offset(0, 12).Value = FCll.Offset(0, 9).Value
      End With
    End If
  Next SCll
  ' odstranit objektove promenne
  Set FCll = Nothing
  Set FBlk = Nothing
  Set SCll = Nothing
  Set SBlk = Nothing
End Sub

[asanplasan]

zdavim a omlouvam se, dostal jsem se na PC az dnes.
udelal jsem vse dle tveho navodu, ale dava mi to chybu: " run-time error ´9´ Subscript out of range " a kdyz dym debug, zlute mi oznaci tento radek:" Set FCll = FBlk.Find(SCll.Value, LookIn:=xlValue, LookAt:=xlWhole)"
pls co jsem udelal spatne?
diky Ashan

[navstevnik]

Psal jsem to v nizsi verzi Excelu v dobre vire, ze je zajistena zpetna kompatibilita (mimo rozdily uvedene MS), bohuzel pro Excel 2007 je nutno v procedure v metode Find pro parametr LookIn pouzit konstantu xlValues namisto xlValue

Kód: Vybrat vše

...
Set FCll = FBlk.Find(SCll.Value, LookIn:=xlValues, LookAt:=xlWhole)
...

[asanplasan]

tak jsem to vyzkousel a funguje je to. diky moc
jeste bych te obtezoval, muzu si nejak ulozit toto makro, aby se nevztahovalo pouze k tomuto konkretnimu sesitu, ale abych si ho mohl zavolat do jineho? dik Ashan

[asanplasan]

asi jsem to nasel, pres export a import, pri zachovani shodneho pojmenovani listu atd to funguje. jeste jednou dekuji a preji hezky den navstevniku

[navstevnik]

Najdi si v napovede heslo Osobni sesit maker