Makro - porovnat, pokud ano prepis

[Hawkey]

Zdravím,
mám opět problémy s makrem. Bojoval jsem s tím sám, ale prostě na makra asi nemám hlavu... Potřebuji makro, kde bude na listu Sheet1 sloupce A s ID čísly a sloupec C s hodnotou (číselná ale i charová) a na listu Sheet2 bude ve sloupci A také ID(budou všechny ze Sheet1, ale jenom některé, kterým se změnila právě hodnota) a s novými hodnotami ve sloupci C. Makro má vždy vzít ID z buňky A ze sešitu Sheet2, najít stejné v Sheet1 a přepsat hodnotu sloupce C sešitu Sheet1 hodnotou ze sešitu Sheet2.
Zkouším si udělat menší tabulkový systém ale tohle nějak nedokážu udělat, pokud by mi tady někdo pomohl nebo poradil jak na to budu velmi rád a ještě radši když tam k tomu občas vloží komentář abych to nemusel jen tupě okopírovat, ale abych aspoň viděl tu logiku a příště už nemusel otravovat.
Předem moc děkuju.

[Reklama]

[navstevnik]

A co takhle prilozit demo soubor.

[Hawkey]

Tady to je...V Sheet1 jsou to sloupce A a W, protoze pak v realu se to bude menit prave v toomhle sloupci. A měnit se tedy mají hodnoty v Sheet1 podle Sheet2. Přiložil jsem menší demo tabulku s ID osob a jejich hodnocením.
A děkuju už teď za zájem.

[navstevnik]

V editoru VBA (Alt+F11) do standardniho modulu vloz nize uvedenou proceduru (prikladove reseni vztahujici se k ukazka.xlsx; definuje bloky, prochazi list Sheet1 a hleda na listu Sheet2, vlozi na Sheet1 nove hodnoty). Volani procedury vyplyne z celeho konceptu, proceduru pripadne uprav podle realu.

Kód: Vybrat vše

Option Explicit

Sub ProhledejNahrad()
  Dim SWsht As Worksheet, SBlk As Range, SCll As Range
  Dim TWsht As Worksheet, TBlk As Range, TCll As Range
  ' definice listu a bloku
  Set SWsht = ActiveWorkbook.Worksheets("Sheet2")
  Set TWsht = ActiveWorkbook.Worksheets("Sheet1")
  With SWsht  ' definovat blok na sheet2
    If Len(.Range("a1").Value) > 0 Then
      Set SBlk = .Range("a1:a" & .Range("a1").Offset(.Cells.Rows.Count - 1, 0).End(xlUp).Row)
      With TWsht  ' definovat blok na sheet1
        If Len(.Range("a1").Value) > 0 Then
          Set TBlk = .Range("a1:a" & .Range("a1").Offset(.Cells.Rows.Count - 1, 0).End(xlUp).Row)
          TBlk.Offset(0, 22).Font.ColorIndex = 0 ' odstranit oznaceni nahrad vw sloupci W:W
          For Each TCll In TBlk.Cells  ' prochazet blok na sheet1
            With SBlk  ' a hledat na sheet2
              Set SCll = .Find(TCll.Value, LookIn:=xlValue, LookAt:=xlWhole)
              If Not SCll Is Nothing Then  ' nalezeno
                TCll.Offset(0, 22).Value = SCll.Offset(0, 2).Value  ' nahradit hodnotu ve sloupci W:W
                TCll.Offset(0, 22).Font.ColorIndex = 3 ' oznacit novou hodnotu
              End If
            End With
          Next TCll
        Else
          MsgBox "Na listu " & TWsht.Name & " nejsou data"
          Exit Sub
        End If
      End With
    Else
      MsgBox "Na listu " & SWsht.Name & " nejsou data"
      Exit Sub
    End If
  End With
  Set SWsht = Nothing
  Set SBlk = Nothing
  Set SCll = Nothing
  Set TWsht = Nothing
  Set TBlk = Nothing
  Set TCll = Nothing
End Sub