VBA Excel - smazání určitého řádku

[Branscombe]

Ahoj, potřeboval bych poradit se zápisem vzorce ve VBA.
Potřebuji smazat každý řádek v listu který má ve sloupci A hodnotu 7.
Raděj ani nebudu psát jak jsem to vymyslel já, stejně to nefunguje a akorát byste se asi pobavili

[navstevnik]

Nasel jsem v archivu proceduru odstranujici radky, a to bud obsahujici v nektere bunce urcitou hodnotu nebo kazdy n-ty radek (podle aktivace casti kodu mezi radky *******), uprav si:

Kód: Vybrat vše

Option Explicit

' odstrani kazdy n-ty radek nebo radek jehoz hodnota = Hodnota
Sub OdstranRadek()
Dim MyArea As Range, MyCell As Range
Dim PoslRadek As Long, NasRadku As Byte
Dim Odstran As Range, Ofs As Long, Hodnota As Variant
  Set MyArea = Worksheets("odstranradky").UsedRange
  If IsEmpty(MyArea) Then End
  PoslRadek = MyArea.Rows.Count ' Worksheets("odstranradky").UsedRange.Rows.Count

  Application.ScreenUpdating = False
' bud odstrani kazdy n-ty radek:
' NasRadku=(1;2;3;4;...,255) - odstrani kazdy(lichy,sudy, 3-ti, 4-ty,...,255-ty) radek
'*********************
'  NasRadku = 2 ' nastavit
'  If NasRadku = 1 Then
'    Set Odstran = Worksheets("odstranradky").Range("2:2").Rows
'    Ofs = -1: NasRadku = 2
'  Else
'    Set Odstran = Worksheets("odstranradky").Range("1:1").Rows
'    Ofs = NasRadku - 1
'  End If
'  Do While Ofs < PoslRadek ' odstrani kazdy n-ty radek
'    If Ofs = 0 Then Ofs = 1
'    Odstran.Offset(Ofs, 0).EntireRow.Delete
'    Ofs = Ofs + NasRadku - 1
'    PoslRadek = PoslRadek - 1
'  Loop
'*********************
' nebo odstrani radek, kde hodnota nektere bunky = Hodnota:
'*********************
  Hodnota = "cd" ' nastavit
  Set Odstran = Worksheets("odstranradky").Range("1:1").Rows
  Ofs = PoslRadek - 1
  Do ' odstraneni radku jehoz hodnota = Hodnota
    For Each MyCell In Odstran.Offset(Ofs, 0).Cells
    If MyCell.Value = Hodnota Then
      Odstran.Offset(Ofs, 0).EntireRow.Delete
      Exit For
    End If
    Next MyCell
    Ofs = Ofs - 1
  Loop While Ofs > -1
'*********************
  Range("a1").Select
  Application.ScreenUpdating = True
End Sub

[Branscombe]

Nějak mi to nefunguje. :-/ Zkoušel jsem si to napsat sám podle sebe a někde je chyba...
Mělo by mi to smazat všechny řádky v listu když v buňce ve sloupci "B" je hodnota "7", ale někde je chybička :-/

Kód: Vybrat vše

Sub Smazat()

For A = 733 To Range("a1048576").End(xlUp).Row
If Cells(1, 2) = "7" Then
 Rows(ActiveCell.Row).Select
 Selection.Delete Shift:=xlUp
End If
Next A

End Sub

[mike007]

Tady to máš, koumáku

[vb]
Sub smazat_sedmicky()
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
End With
With ActiveSheet
.Select
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
.DisplayPageBreaks = False
Firstrow = .UsedRange.Cells(1).Row
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
For Lrow = Lastrow To Firstrow Step -1
With .Cells(Lrow, "A") ' Sloupec s hledanými podmínkami
If Not IsError(.Value) Then
Select Case .Value
Case Is = "7": .EntireRow.Delete 'podmínka v uvozovkách
End Select
End If
End With
Next Lrow
End With
ActiveWindow.View = ViewMode
With Application
.Calculation = CalcMode
End With
End Sub
[/vb]

[Branscombe]

Super - funguje... Díky moc, ale to to opravdu nejde zapsat jednodušeji ?? Něco jako jsem psal já ??

[mike007]

Samozřejmě že jde, ale to předchozí makro provede job v objemných dokumentech rychleji.

Tady máš tedy to jednodušší:

[vb]

Sub smazat_sedmicky()
For a = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If Cells(a, 1) = "7" Then Cells(a, 1).EntireRow.Delete
Next a
End Sub

[/vb]

[Branscombe]

Super, díky

[Branscombe]

Ahoj, vzhledem k tomu že mi to makro stále nefunguje, přikládám soubor...

Potřeboval bych makro které mi smaže veškeré řádky v oblasti A4:A"poslední buňka" obsahující ve sloupci 2 podmínku z B1 a ve sloupci 3 podmínku z B2

[navstevnik]

Muzes pouzit napr. tuto proceduru (odstrani vsechny radky mezi vychozim radkem a poslednim radkem splnujicim podminku vcetne techto radku):

Kód: Vybrat vše

Option Explicit

Sub SmazRadky()
  Dim Condt1, Condt2, Cll As Range
  Dim Blk As Range, i As Long, Tmp As String
  With ActiveSheet
    '    Set Cll = .Range("a4")
    On Error Resume Next
    Set Cll = Application.InputBox("Zadej vychozi bunku kliknutim mysi nebo vepsanim", , , , , , , Type:=8)
    If Err.Number <> 0 Then MsgBox "Chybne zadani": Exit Sub
    On Error GoTo 0
    Condt1 = .Range("b1").Value
    Condt2 = .Range("b2").Value
    i = 0
    Tmp = vbNullString
    Do While Cll.Offset(i, 0).Value <> vbNullString
      If Cll.Offset(i, 1).Value = Condt1 And Cll.Offset(i, 2).Value = Condt2 Then
        Tmp = Cll.Offset(i, 0).Address(0, 0)
      End If
      i = i + 1
    Loop
    If Tmp <> vbNullString Then
      Set Blk = .Range("a4:" & Tmp)
'      Debug.Print Blk.Address
      Blk.EntireRow.Delete
    Else
      MsgBox "Nebyl nalezen radek splnujici podminky"
    End If
  End With
  Set Cll = Nothing
  Set Blk = Nothing
End Sub

[Branscombe]

Hm... To asi není to co jsem potřeboval, jelikož to maže všechny řádky až do chvíle než to najde řádek dle zadaných kritérií, ale když to nebudu mít seřazeno tak to nebude fungovat ...

[mike007]

Otevřel jsem staré téma a příspěvky sloučil. Příště téma neoznačuj za vyřešené, když to vyřešené nemáš, nebo případně napiš, abych staré téma znovu odemkl. Díky

[Branscombe]

Díky, nevěděl jsem jak to s tím odemykáním funguje ...
Nějakou radu na to makro bys neměl ??