Makro na smazání všech řádků, které neobsahují podmínku Vyřešeno

[marek26]

Prikaz na zmazanie riadkov ktore neobsahuju v stlpci "ičo"

Prosim vas, asi tam mam chybicku, teraz potrebujem aby v stlpci B, ak bunka neobsahuje IČO, tak nech vymaze cele riadky (cize zostanu mi riadky take, ktore v stlpci B obsahuje "ičo") ale tento prikaz len prejde ale nic sa neudeje...

V prilohe je vzorovy subor, cize ak prejde prikaz chcem tento subor mat ocisteny tym ze makro vymaze vsetky riadky ktore v stlpci B neobsahuje "ičo" Ak bude prikaz obsahovat aj to ze vymaze hned cely stlpec A aj stlpec C budem rad.

Kód: Vybrat vše

 Workbooks.Open Filename:="C:\Users\marek\Documents\konkurzy.xls"
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, "B")
If Not IsError(.Value) Then
Select Case .Value
Case Is <> "*IČO*": .EntireRow.Delete
End Select
End If
End With
Next Lrow
End With
ActiveWindow.View = ViewMode
With Application
.Calculation = CalcMode
End With
End Sub

Diky diky moc za opravu tohto prikazu

// Změna názvu tématu z nic neříkajícího "oprava v uz hotovem kodu ...makro"
// mike007

[Reklama]

[navstevnik]

Upravena procedura (vloz do sesitu konkurzy.xls v editoru VBA do standardniho modulu):

Kód: Vybrat vše

Option Explicit

Sub Odstran()
  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, "B")
        If Not IsError(.Value) Then
          If InStr(.Value, "IČO") = 0 Then .EntireRow.Delete
        End If
      End With
    Next Lrow
    .Range("C:C").EntireColumn.Delete
    .Range("A:A").EntireColumn.Delete
  End With
  ActiveWindow.View = ViewMode
  With Application
    .Calculation = CalcMode
  End With
End Sub

[marek26]

Ano to je presne ono co potrebujem.........

Velke diky NAVSTEVNIK.....vdaka.....Marek