< návrat zpět

MS Excel

Téma: Výmaz řádku podle hodnoty v konkrétním sloupci rss

Zaslal/a Alfan 7.2.2023 11:44

AlfanDobrý den,
chci se zeptat, zda byste mi pomohli s makrem, které by vymazalo na listu, který je ve formátu tabulky příslušný řádek, když je v konkrétním sloupci nějaký hodnota?
Na listu "faktury" mám tabulku "DataFaktury".
A potřeboval bych, aby makro konkrétně ve sloupci číslo 11 prohledávalo jednotlivé buňky a pokud by byla v buňce hodnota "#NENÍ_K_DISPOZICI", tak by se řádek s touto hodnotou vymazal.
A takto by to zkontrolovalo a případně vymazalo všechny buňky (řádky) v tom sloupci číslo 11.
Děkuji.
Radek

Příloha: zip54369_wall.zip (11kB, staženo 2x)
Zaslat odpověď >
Strana:  1 2   další »
Alfan(7.2.2023 14:02)#054370
Alfan
Vyřešeno:
Sub DeleteRows()

Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("faktury")

Dim tbl As ListObject
Set tbl = ws.ListObjects("DataFaktury")

Dim lastRow As Long
lastRow = tbl.Range.Rows.Count

Dim i As Long
For i = lastRow To 1 Step -1
If IsError(tbl.DataBodyRange.Cells(i, 11).Value) Then
tbl.DataBodyRange.Rows(i).Delete
End If
Next i

MsgBox ("ŘÁDKY VYMAZÁNY")

End Subcitovat
elninoslov(7.2.2023 21:49)#054371
elninoslov
Ja by som to videl na SpecialCells
Sub DeleteRows()
Dim rngErr As Range, ErrCount As Long

With wsFaktury.ListObjects("DataFaktury")
On Error Resume Next
Set rngErr = .ListColumns(11).Range.SpecialCells(xlCellTypeFormulas, xlErrors) 'všechny buňky s chybou ve 11. sloupci Tabulky
On Error GoTo 0

If rngErr Is Nothing Then MsgBox "Žádné chyby", vbInformation: Exit Sub 'žádné chyby

ErrCount = rngErr.Cells.Count
' If ErrCount = .DataBodyRange.Rows.Count Then .ListRows.Add 'asi není potřeba, ale pokud jsou všechny buňky s chybou, přidej 1 řádek, pro zachování vzorců a formátů

Intersect(.DataBodyRange, rngErr.EntireRow).Delete Shift:=xlUp 'odstranění řádků
MsgBox "VYMAZÁNO " & ErrCount & " ŘÁDKŮ", vbExclamation 'informativní výpis počtu chyb
End With
End Sub
Příloha: zip54371_mazanie-riadkov-tabulky-s-chybou.zip (17kB, staženo 2x)
citovat
Alfan(8.2.2023 7:22)#054372
Alfan
Děkuji 1

Já ještě budu testovat to moje původní s tím, že buď to bude na Error nebo na konkrétní text nebo na konkrétní hodnotu:
If IsError(tbl.DataBodyRange.Cells(i, 11).Value) Then tbl.DataBodyRange.Rows(i).Delete

If tbl.DataBodyRange.Cells(i, 11).Value = "něco" Then tbl.DataBodyRange.Rows(i).Delete

If tbl.DataBodyRange.Cells(i, 11).Value = 900 Then tbl.DataBodyRange.Rows(i).Deletecitovat
elninoslov(8.2.2023 18:54)#054373
elninoslov
Takto?
Sub DeleteRows()
Dim rngDel As Range, DelCount As Long, D(), i As Long, bDel As Boolean

With wsFaktury.ListObjects("DataFaktury")
With .ListColumns(11).Range
D = .Value2
For i = 2 To UBound(D, 1)
bDel = IsError(D(i, 1)) 'mazat při chybě
If Not bDel Then
Select Case D(i, 1)
Case "něco", 900: bDel = True 'nebo mazat při těchto hodnotách, hodnoty lze lehce přidat
End Select
End If

If bDel Then If rngDel Is Nothing Then Set rngDel = .Cells(i) Else Set rngDel = Union(rngDel, .Cells(i))
Next i
End With

If rngDel Is Nothing Then MsgBox "Žádné řádky k smazání", vbInformation: Exit Sub 'žádné řádky k smazání

DelCount = rngDel.Cells.Count
Intersect(.DataBodyRange, rngDel.EntireRow).Delete Shift:=xlUp 'odstranění řádků
MsgBox "VYMAZÁNO " & DelCount & " ŘÁDKŮ", vbExclamation 'informativní výpis počtu chyb
End With
End Sub
Příloha: zip54373_mazanie-riadkov-tabulky-s-chybou-a-zadanou-hodnotou.zip (21kB, staženo 2x)
citovat
Alfan(9.2.2023 9:57)#054377
Alfan
Super, to je ono.

Jen mě ještě napadlo, jestli by se dal použít třeba nějaký pomocný list, třeba s názvem "hodnoty", kde by se pod sebe v prvním sloupci zadaly hodnoty (makro by prohledalo první sloupec), které by se využili v této části makra.

Case "něco", 900: bDel = True 'nebo mazat při těchto hodnotách, hodnoty lze lehce přidat

Jen proto, aby někdo nemusel editovat makro.

Ale jinak je pro mě i toto dostačující.
Ještě jednou děkuji.
Radekcitovat
elninoslov(9.2.2023 13:52)#054381
elninoslov
To je úplne jednoduché.
Sub DeleteRows()
Dim rngDel As Range, DelCount As Long, D(), i As Long, colDel As New Collection, Check

D = wsHodnoty.ListObjects("tblMazatHodnoty").ListColumns(1).Range.Value2
On Error Resume Next
For i = 2 To UBound(D, 1) 'vytvoření kolekce mazaných hodnot z tblMazatHodnoty
colDel.Add CStr(D(i, 1)), CStr(D(i, 1))
Next i

With wsFaktury.ListObjects("DataFaktury")
With .ListColumns(11).Range
D = .Value2

For i = 2 To UBound(D, 1)
Check = colDel(CStr(D(i, 1))) 'mazat při hodnotách z tblMazatHodnoty, hodnoty lze lehce editovat
If Err.Number = 0 Then
If rngDel Is Nothing Then Set rngDel = .Cells(i) Else Set rngDel = Union(rngDel, .Cells(i))
Else
Err.Clear
End If
Next i
End With
On Error GoTo 0

If rngDel Is Nothing Then MsgBox "Žádné řádky k smazání", vbInformation: GoTo KONEC 'žádné řádky k smazání

DelCount = rngDel.Cells.Count
Intersect(.DataBodyRange, rngDel.EntireRow).Delete Shift:=xlUp 'odstranění řádků
MsgBox "VYMAZÁNO " & DelCount & " ŘÁDKŮ", vbExclamation 'informativní výpis počtu chyb
End With

KONEC:
Set colDel = Nothing
End Sub
A nebolo by pre Vás vhodnejšie PowerQuery s výslednou Tbl do druhého listu/súboru ???
Příloha: zip54381_mazanie-riadkov-tabulky-podla-zadanych-hodnt-v-tbl.zip (24kB, staženo 3x)
citovat
Alfan(10.2.2023 8:16)#054387
Alfan
Děkuji 1
To PQ asi ne, protože ne všichni mají Office, kde PQ běží.citovat
Alfan(15.2.2023 7:13)#054464
Alfan
@elninoslov
Přeci jenom se chci zeptat, jak by bylo složité toto řešit přes PQ, jak píšete?
Jak jste mi popsal tu Transpozici přes PQ, tak to bylo pro mne pochopitelné.
Děkuji.
Radekcitovat
Alfan(15.2.2023 15:47)#054466
Alfan

elninoslov napsal/a:

Ja by som to videl na SpecialCells
Sub DeleteRows()
Dim rngErr As Range, ErrCount As Long

With wsFaktury.ListObjects("DataFaktury")
On Error Resume Next
Set rngErr = .ListColumns(11).Range.SpecialCells(xlCellTypeFormulas, xlErrors) 'všechny buňky s chybou ve 11. sloupci Tabulky
On Error GoTo 0

If rngErr Is Nothing Then MsgBox "Žádné chyby", vbInformation: Exit Sub 'žádné chyby

ErrCount = rngErr.Cells.Count
' If ErrCount = .DataBodyRange.Rows.Count Then .ListRows.Add 'asi není potřeba, ale pokud jsou všechny buňky s chybou, přidej 1 řádek, pro zachování vzorců a formátů

Intersect(.DataBodyRange, rngErr.EntireRow).Delete Shift:=xlUp 'odstranění řádků
MsgBox "VYMAZÁNO " & ErrCount & " ŘÁDKŮ", vbExclamation 'informativní výpis počtu chyb
End With
End SubPříloha: 54371_mazanie-riadkov-tabulky-s-chybou.zip (17kB, staženo 1x)


Vždycky se mi to zasekne na:
With wsFaktury.ListObjects("DataFaktury")citovat
elninoslov(15.2.2023 16:17)#054467
elninoslov
Dnes ma neskutočne bolí rameno. Človek by neveril, ako hýbe ramenom pri prekladaní ruky z myši na klávesku. Ak to nepovolí, nerobím dnes ani prd ... sorry.
Příloha: png54467_codenamelist.png (97kB, staženo 18x)
54467_codenamelist.png
citovat

Strana:  1 2   další »

Uživatelské menu

Nejste přihlášen(a)
avatar\n

Menu

Formulář Faktura

Formulář Faktura IV

Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.

Helios iNuvio

Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.

On-line nástroje