Přidat otázku mezi oblíbenéZasílat nové odpovědi e-mailem Algoritmus nebo pomoc v Excelu

Dobrý den potřeboval bych pomoc s algoritmem.
Potřeboval bych označit jednotlivé řádky... ne sloupce.
Potřeboval bych označit celé řádky pokud se v nějaké buňce v určitém řádku Vyskytné daný řetězec.
Takže aby mi v celém listu, v případě že se na řádku například 7 kterékoliv buňce objeví například název Tereza tak aby mi Excel označil celý tento řádek.
Jako aby zmodral.
V tom listu bude mnoho řádků ve kterých bude název Tereza v jednotlivých buňkách.
Já bych potřeboval ty řádky vyselektovat A nakopírovat všechny řádky kde je buňka s názvem Tereza do nového listu.
Když to udělám příkazem najít a vyhledat, tak se mi označí pouze jednotlivé buňky ve kterých je nápis Tereza ale neoznačí se mi celý ten řádek.
A označovat celé zátky posléze ručně je hodně zdlouhavé.
Tak bych se chtěl zeptat jestli neexistuje řešení.
Děkuji za odpovědi.

Jsou zobrazeny jen nové odpovědi. Zobrazit všechny
Předmět Autor Datum
Option Explicit Sub Kopiruj_TEREZU() Dim Oblast As Range Dim Radek As Range Dim Bunka As Range Dim K… nový
Siki83 17.10.2021 22:38
Siki83
Paráda, moc děkuji... Páni, to muselo dát práce. Díky moc. nový
fstary 22.10.2021 00:44
fstary
Uvažuju, jak tam ještě dostat input box se zadáním hledaného textu, když zítra bude třeba hledat Mař… nový
L-Core 22.10.2021 07:37
L-Core
Jednoduxho namiesto "Tereza" napíšeš searchString, ktorý bude vopred nastavený napríklad tým InputBo… nový
pozorovateľ 22.10.2021 08:11
pozorovateľ
Jo, to je ono. Dovolím si tedy upravit ten Sikiho kód: Sub Kopiruj_cokoliv() Dim Oblast As Range Di… nový
L-Core 22.10.2021 08:44
L-Core
Aj to sa dá ľahko vyriešiť, namiesto priameho porovnania obsahu bunky sa použije funkcia INSTR, čiže… poslední
pozorovateľ 22.10.2021 08:50
pozorovateľ
Option Explicit

Sub Kopiruj_TEREZU()
Dim Oblast As Range
Dim Radek As Range
Dim Bunka As Range
Dim KopirovanaOblast As Range

Set Oblast = List1.UsedRange

For Each Radek In Oblast.Rows
    For Each Bunka In Radek.Cells
        If Bunka.Value = "Tereza" Then
            If KopirovanaOblast Is Nothing Then
                Set KopirovanaOblast = Bunka.EntireRow
                Exit For
            Else
                Set KopirovanaOblast = Union(KopirovanaOblast, Bunka.EntireRow)
                Exit For
            End If
        End If
    Next Bunka
Next Radek

If Not KopirovanaOblast Is Nothing Then
    KopirovanaOblast.Copy List2.Range("A1")
    If ActiveSheet.CodeName = "List1" Then List1.Range("A1").Select
    MsgBox "Kopírování dokončeno.", vbInformation, "Hotovo"
Else
    MsgBox "Žádná data ke kopírování.", vbExclamation, "Varování"
End If

Set Oblast = Nothing
Set KopirovanaOblast = Nothing
Set Bunka = Nothing
End Sub

Jo, to je ono.
Dovolím si tedy upravit ten Sikiho kód:

Sub Kopiruj_cokoliv()
Dim Oblast As Range
Dim Radek As Range
Dim Bunka As Range
Dim KopirovanaOblast As Range

searchString = InputBox("Zadej hledaný text")

Set Oblast = List1.UsedRange

For Each Radek In Oblast.Rows
    For Each Bunka In Radek.Cells
        If Bunka.Value = searchString Then
            If KopirovanaOblast Is Nothing Then
                Set KopirovanaOblast = Bunka.EntireRow
                Exit For
            Else
                Set KopirovanaOblast = Union(KopirovanaOblast, Bunka.EntireRow)
                Exit For
            End If
        End If
    Next Bunka
Next Radek

If Not KopirovanaOblast Is Nothing Then
    KopirovanaOblast.Copy List2.Range("A1")
    If ActiveSheet.CodeName = "List1" Then List1.Range("A1").Select
    MsgBox "Kopírování dokončeno.", vbInformation, "Hotovo"
Else
    MsgBox "Žádná data ke kopírování.", vbExclamation, "Varování"
End If

Set Oblast = Nothing
Set KopirovanaOblast = Nothing
Set Bunka = Nothing
End Sub

Doplním, že kód nefunguje na čísla (vyhledat třeba "56") ani na části textu v buňkách (nenajde "Tereza" v buňce s "Tereza Nováková"). Hledání je také case sensitive, nenajde tedy "tereza".

Zpět do poradny Odpovědět na původní otázku Nahoru