PC-HELP.CZ

Zdravím odborníky !
Sice jsem tady studoval stará témata a starší příspěvky, ale zaboha jsem to nedal dohromady, aby to bylo funkční. Potřebuju makro, jenž prohledá list a smaže celé řádky, které ve sloupci A neobsahují řetězec nebo znaky např. "ABC" anebo ve sloupci B neobsahují znaky např. "DEF". Data nelze setřídit.
Jsem z toho už lama jelenovitá .... :mad:

Děkuji všem za případné tipy.

Ahoj,
Vyzkoušej na kopii dat toto.

Kód: Vybrat vše

Sub SmazUdaje()
Dim radek, radky As Long

radky = Cells(Rows.Count, 1).End(xlUp).Row 'zjisteni poctu radku ze sloupce A

Application.ScreenUpdating = False

    'nastavime od jakeho po jaky radek
    For radek = 1 To radky
        ' kontrola sloupcu A a B
       If Cells(radek, "A").Value <> "ABC" Or Cells(radek, "B").Value <> "DEF" Then
           'smazani udaju
          Rows(radek).Delete Shift:=xlUp
       End If
    Next
    Range("A1").Select
    
Application.ScreenUpdating = True

    MsgBox "Údaje promazány.", vbInformation
End Sub

Ano, takhle nějak jsem to měl také .... ale já potřebuju vymazat vše ostatní a právě řádky, které obsahují buňky ABC a DEF ponechat ! :roll:

Tak tady je oprava

Kód: Vybrat vše

...

Edit 11.4.1:57
kod odstraněn - nahrazen následujícím

Mno, ano, takhle se to bezvadně zacyklí a neudělá nic ....

To nevím mě to jde dobře v sešitě co jsem si udělal.
Tak pošli sešit pokud to jde.

Tak tady to je ....

Tak teď by už mohlo

, já si nevšim, že to může být i část textu.

Kód: Vybrat vše

Sub SmazUdaje()
Dim radek, radky As Long

radky = Cells(Rows.Count, 1).End(xlUp).Row 'zjisteni poctu radku ze sloupce A

Application.ScreenUpdating = False

    'nastavime od jakeho po jaky radek
    For radek = radky To 1 Step -1
       
    Set Found1 = Range("A" & radek).Find(What:="abc")
    Set Found2 = Range("B" & radek).Find(What:="def")

       If Not Found1 Is Nothing Then GoTo dalsi
         If Not Found2 Is Nothing Then GoTo dalsi
            'smazani udaju
            Rows(radek).Delete Shift:=xlUp
dalsi:
    Next
   
Application.ScreenUpdating = True

Range("A1").Select
MsgBox "Údaje promazány.", vbInformation

Set Found1 = Nothing
Set Found2 = Nothing
End Sub

No jo, sakra, ono to fakt funguje ! :smile:

Chlape, jsi hlava, děkuju za návod ! :wink:

PC-HELP.CZ

VBA Excel - smazání řádků

VBA Excel - smazání řádků

Re: VBA Excel - smazání řádků

Re: VBA Excel - smazání řádků

Re: VBA Excel - smazání řádků

Re: VBA Excel - smazání řádků

Re: VBA Excel - smazání řádků

Re: VBA Excel - smazání řádků

Re: VBA Excel - smazání řádků

Re: VBA Excel - smazání řádků