Excel - VBA porovnání buňek a následné kopírování Vyřešeno

[Fefro]

Ahoj všem,

potřeboval bych poradit s jedním makrem. V příloze je soubor. Potřebuji na listu1 ve sloupci A najít text z listu2 sloupce A a podle shody zkopírovat hodnotu ze sloupce B z listu2 do sloupce B na listu1. (To co z toho chci dostat je v souboru Výsledek.xlsx)

Doufám že je dotaz srozumitený a všem děkuji za rady.

[Reklama]

[Fefro]

Ahoj všem,
zatím jsem dal dohromady následující

Kód: Vybrat vše

Sub pokus()
Dim List1 As Worksheet, Blok1 As Range, Bunka1 As Range
Dim List2 As Worksheet, Blok2 As Range, Bunka2 As Range
  ' definice listu a bloku
  Set List1 = ActiveWorkbook.Worksheets("List1")
  Set List2 = ActiveWorkbook.Worksheets("List2")
  With List1  ' definovat blok na List1
    If Len(.Range("a1").Value) > 0 Then
      Set Blok1 = .Range("a1:a" & .Range("a1").Offset(.Cells.Rows.Count - 1, 0).End(xlUp).Row)
      With List2  ' definovat blok na List2
        If Len(.Range("a1").Value) > 0 Then
          Set Blok2 = .Range("a1:a" & .Range("a1").Offset(.Cells.Rows.Count - 1, 0).End(xlUp).Row)
            For Each Bunka2 In Blok2.Cells  ' prochazet blok na List2
            With Blok1  ' a hledat na List1
              Set Bunka1 = .Find(Bunka2.Value)
                If Not Bunka1 Is Nothing Then
                Bunka1.Offset(0, 1).Value = Bunka2.Offset(0, 1).Value  ' nahradit hodnotu
                End If
            End With
            Next Bunka2
        Else
          MsgBox "Na listu " & List2.Name & " žádná data"
          Exit Sub
        End If
      End With
    Else
      MsgBox "Na listu " & List1.Name & " žádná data"
      Exit Sub
    End If
  End With
  Set List1 = Nothing
  Set Blok1 = Nothing
  Set Bunka1 = Nothing
  Set List2 = Nothing
  Set Blok2 = Nothing
  Set Bunka2 = Nothing
End Sub

Nevíte někdo co doplnit aby makro zkopírovalo buňku B z listu2 do všech příslušných řadků Listu1 a ne jenom do první kterou najde?

Předem děkuji za rady

[cmuch]

Já udělal dnes v práci něco podobného,
Nejsou tam teda ty tvé MSGBOXy
Funguje to skvěle, ale až na to. že ty buňky musí být shodné , ne jak u tebe pouze část.

Kód: Vybrat vše

Sub KopirujHodnoty()
  Dim SList As Worksheet, BlkA As Range, SCll As Range
  Dim TList As Worksheet, BlkB As Range, TCll As Range
 
  Set SList = ActiveWorkbook.Worksheets("List1")
  Set TList = ActiveWorkbook.Worksheets("List2")
' definovani bloku bunek na listech
      With SList
        Set BlkA = .Range(("a1:a") & .Cells(.Rows.Count, "a").End(xlUp).Row)
     
      With TList
        Set BlkB = .Range(("a1:a") & .Cells(.Rows.Count, "a").End(xlUp).Row)
     
' prochazet BlkA
     For Each TCll In BlkA.Cells
' prohledavat BlkB
      With BlkB
        Set SCll = .Find(TCll.Value)
        If Not SCll Is Nothing Then ' pri shode zkopirovat hodnotu sl.B do listu1 sl.B
        TCll.Offset(0, 1).Value = SCll.Offset(0, 1).Value
        End If
      End With
     Next TCll
    End With
    End With
' odstranit promenne
  Set SCll = Nothing
  Set BlkA = Nothing
  Set SList = Nothing
  Set TCll = Nothing
  Set BlkB = Nothing
  Set TList = Nothing
End Sub


Ale třeba mám někde chybku.

[Fefro]

Ahoj,

takhle jsem to měl také. Pokud tam máš:
Set SCll = .Find(TCll.Value)
tak to funguje bez chyby akorát hledáš hodnotu z listu1 v listu2.( buňky nemusí být shodné, ale buňka na listu2 musí obsahovat řetězec z buňky na listu1).
já to otočil (v tvém případě):
Set TSCll = .Find(SCll.Value)
a už mi to tak perfektně nechodí :(
potřeboval bych tam doplnit druhej cyklus ale nedaří se a nedaří :(

Napadá někoho jak to rozchodit?

Předem dík všem

[cmuch]

Tak jsem na to přišel

Do tvého kodu vlož za
If Not Bunka1 Is Nothing Then

Kód: Vybrat vše

frstAddr = Bunka1.Address
              Do
                Bunka1.Offset(0, 1).Value = Bunka2.Offset(0, 1).Value  ' nahradit hodnotu
              Set Bunka1 = .FindNext(Bunka1)
              Loop While Bunka1.Address <> frstAddr

a bude to fakčit

Edit:
Ještě definuj
Dim frstAddr As String

[Fefro]

Super už to chodí tak jak má :)

Díky moc za rady