Excel - jedno makro pro více úloh

Problém
Řešení
Poznámka

Problém

Mám dva samostatné sešity, které musím porovnat. Úkol po ruce je, že musím najít konkrétní text v sešitu 2 (sloupec A) a jednou nalezený - pak musím zkopírovat další dvě buňky / řádky (sloupec B a C) a vložit je do wkbook 1 (sloupec B a C) pro každý jednotlivý řádek nalezeného textu. Ty, které nejsou nalezeny, mohou být ponechány samy nebo prázdné.

Řešení

Můžete použít toto:

 Dim mySearchText jako řetězec Dim wb1, wb2 Jako sešit Dim sh1, sh2 Jako listy Nastavit wb1 = sešity ("Book1") Nastavit wb2 = sešity ("Book2") Proveďte při true mySearchText = InputBox ("Zadejte text pro hledání. Zadejte prázdný ukončit operaci. ", " Hledat ") Pokud (mySearchText =" ") Pak ukončete Sub wb2.Activate wb2BRow = Buňky (65536, 2) .End (xlUp) .Row wb2CRow = Buňky (65536, 3) .End ( xlUp) .Row Pokud (wb2BRow> wb2CRow) Pak wb2row = wb2BRow Else wb2row = wb2CRow Konec If Pokud wb2row = 1 Pak wb2row = 2 wb1.Activate Při chybě Resume Next Pokud ActiveSheet.AutoFilterMode pak Cells.Select Selection.AutoFilter End If IfSheet \ t .AutoFilterMode = False Potom Řádky (1) .Vybrat Selection.AutoFilter End If On Error GoTo 0 Pole Selection.AutoFilter: = 1, Kritéria1: = "=" & mySearchText, Operator: = xlAnd Dim lastRow As Long lastRow = Buňky (65536, 1) .End (xlUp) .Row Pokud (lastRow> 1) Pak Rozsah (Buňky (2, 2), Buňky (lastRow, 3)) Vyberte Selection.Copy wb2.Activate Cells (wb2row, 2). .PasteSpecial wb2BRow = Buňky (65536, 2) (xlUp) .Row wb2CRow = Buňky (65536, 3) .End (xlUp) .Row Pokud (wb2BRow> wb2CRow) Pak wb2row = wb2BRow Else wb2row = wb2CRow Konec Pokud wb2row = wb2row + 1 End If Loop