Jak odstranit prázdné řádky pouze v tabulce

[BobanekOs]

Dobrý den

Pokouším se vytvořit makro, které projde tabulku v oblasti A10 až G1000 a smaže všechny řádky, které nemají žádnou hodnotu právě ve sloupci G. Našel jsem a částečně upravil makro, které zmíněný rozsah prohledá a promazává:

Kód: Vybrat vše

Sub OdstranPrazdneR()
    Dim rngOblast As Range
    Set rngOblast = Range("A10:G100")
    With rngOblast
        .Replace What:="", Replacement:="=NA()", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
        .SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete
    End With
End Sub


Bohužel, mám dva problémy:
1) I když je ve sloupci G nějaká hodnota, tak mi to řádek smaže, kdy není hodnota v jiném sloupci. Tedy, zanechává jen ty řádky, u nichž jsou vyplněny všechny buňky v řádku a když kterákoli buňka vyplněna není, smaže jej.
2) Smaže řádek celého listu, ale já potřebuji, aby smazal pouze řádek od sloupce A do sloupce G a všechny pod tím vždy posunul nahoru.

Řešením je, že bych prohledával pouze oblast

Kód: Vybrat vše

Set rngOblast = Range("G10:G100")

a upravit makro tak, aby v případě nulové hodnoty smazal řádek v rozsahu sloupců A až G.

Neporadíte někdo, jak to udělat?

[Kurimak]

Kód: Vybrat vše

Sub Smaz_prazdny_radek()
Dim i As Long
Dim r As Long

Application.ScreenUpdating = False

For i = 1000 To 10 Step -1

  If Cells(i, 7) = "" Then
    Range(Cells(i, 1), Cells(i, 7)).ClearContents
    r = Cells(Rows.Count, 1).End(xlUp).Row
    Range(Cells(i + 1, 1), Cells(r, 7)).Cut Cells(i, 1)
  End If

Next i

Application.ScreenUpdating = True

End Sub

[BobanekOs]

Kurimak: Moc děkuji. Dělá to přesně to, co potřebuji. Pomohl jsi mi.

[BobanekOs]

Nechci jen hloupě kopírovat a rád bych se i něco naučil, takže jestli mohu, rád bych si ověřil, zda jsem pochopil a googlil správně:

1) Na začátku jsem pojmenoval makro a vytvořil proměnné "i" a "r" datového typu Long.
2) Vypnutí "Application.ScreenUpdating" na začátku a zapnutí na konci zamezí zobrazování každého kroku makra.
3) Cyklus "For"mi bude měnit hodnotu od 1000 do 10, které budu vkládat jako hodnotu při každém průchodu cyklu
4) Kód uvnitř "For" už moc nechápu, ale předpokládám, že se neustále mění hodnota proměnné"i" a "r", takže se projíždí jednotlivé řádky v určeném rozsahu a následně je tam kontrola, zda je hodnota v buňce a když ne, smaže se řádek a ostatní se "nějak" posunou nahoru.

Pochopil jsem sice jen částečně, ale stačilo k tomu, abych si upravil například rozsah kontrolovaných buněk a nebo kontrolní sloupec. Zmenšil jsem rozsah na 100 řádků a makro se vykonává delší dobu. Protože se ale prochází řádek po řádku, asi to rychleji stejně nepůjde a každém případě je to ohromně rychlejší, než to dělat ručně. Ještě mi tam záhadně zůstává jeden řádek, ale na to se ještě pokusím přijít.

Ještě jednou děkuji za pomoc

[Kurimak]

Kód: Vybrat vše

If Cells(i, 7) = "" Then 'Když je buňka prázdná, tak se vymaže obsah buněk
    Range(Cells(i, 1), Cells(i, 7)).ClearContents ' v rozsahu sloupců A až G.
    r = Cells(Rows.Count, 1).End(xlUp).Row ' Zjištění řádku  poslední buňky v tabulce,
     'která je vyplněna.
    Range(Cells(i + 1, 1), Cells(r, 7)).Cut Cells(i, 1) 'Vyjme se celá oblast pod smazaným řádkem
    'a vloží do řádku smazaného.
End If

A nemohly by se řádky mazat celé - i mimo oblast sloupců A-G, pak by mohlo být makro mnohem rychlejší.
Nebo je ve sloupcích H - XFD něco vloženo?:

Kód: Vybrat vše

Sub Smaz_prazdny_radek2()
Dim i As Long
Dim r As Long

Application.ScreenUpdating = False

For i = 1000 To 10 Step -1
If Cells(i, 7) = "" Then
Cells(i, 7).EntireRow.Delete
End If
Next i

Application.ScreenUpdating = True

End Sub

[BobanekOs]

Popravdě, nevím jak jinak to udělat.

Takto bude vypadat to, co se pokouším udělat:


Jedná se o formát A4. Ve vrchní části jsou řezy výrobkem a detaily. Do spodní části potřebuji vložit razítko (obdoba razítka v technickém CAD výkresu) a tabulka, která je mnohem větší, než je místo v dokumentu. V tuto chvíli tedy máme malou tabulku s malinkatým písmem a přesto musíme ručně vypisovat.

Chci udělat tabulku, která by si hodnoty vypisovala automaticky na základě vzorců a trochu zvětšit písmo, ať to všichni přečtou, takže vypíšu, kliknu na tlačítko, a tabulka se mi "sroluje" do prostoru, kde bude vše vytištěno.

Nenapadlo mě, jak jinak to udělat, no