Microsoft Excel & VBA

Na webu excelplus.net se objevil dotaz na efektivním odstranění řádku dle číselníku na jiném listě. (V tomto odkazu naleznete sešit s všemi ukázkami kódu níže)Zaujalo mě hlavně slovíčko efektivně. Již sem se chtěl rozepsat o cyklu přes všechny řádky a kontrole hodnot s číselníkem, ale rozhodl jsem se prověřit také další možnosti a nevyužil jsem zdaleka všechny.

Dotaz byl následující;
Ahoj, mám následující problém a nevím, jak na něj co nejefektivněji: Ze seznamu řetězců (x řádků) potřebuji odmazat záznamy (řádky), které obsahují některé ze slov, které mám uvedené např. v číselníku na listu.

V podstatě podobnou úlohu umí splnit Automatický filtr (kritérium "neobsahuje"), ale ten umí max. 2 kritéria. Naproti tomu Rozšířený filtr neumí kritérium "NEOBSAHUJE"

Nejdříve bych se zastavil u rozšířeného filtru. Ten samozřejmě podporuje operátor "<>" (nerovno), ale hodnoty se musí psát do jednotlivých sloupců což je celkem pracné a neefektivní. Vypadalo by to asi nějak takto



Jak sami vidíte při větším počtu kritérii by nám nemusel stačit počet sloupců ..
Rozhodl jsem se otestovat tři nejběžnější postupy, které by zvolila většina z nás. Určitě by se našly i jiné postupy a sofistikovanější ale snad Vám bude stačit prezentace těchto tří

• Cyklus přes všechny řádky a porovnání s číselníkem
• Využití metody FIND a FINDNext Excelu a následného odstranění řádku
• ADODB a SQL dotaz
• Použít automatický nebo rozšířený filtr a mazat řádky - nezkoušel jsem

add1) Cyklus přes všechny řádky a porovnání s číselníkem
Tento krok napadne asi úplně každého a proto jsem se ho rozhodl vyzkoušet také. Činnost kódu je jednoduchá. Nejdříve naplní pole s listu Číselník a poté si zjisti poslední obsazený řádek na listu s Daty a prochází všechny řádky odspodu nahoru a kontroluje v cyklu s hodnotami v poli a podle toho maže celý řádek nebo pokračuje dál. Celkový čas zpracování se pohyboval okolo 10-11 sec.

'-------------------  Begin Comment --------------------------
' Comment:      Odstrani radky s daty kde se shoduji hodnoty ve '               sloupci B
'               s hodnotami na listu "Ciselnik"
'               Pouziva metody prochazeni cyklem nad kazdou '               bunkou.
'
' Arguments:    Without arguments
'
' Date             Author               Action
'--------------------------------------------------------------
' 10/21/2008    Premysl Lazecky         Created
Sub Delete_Choosen_Data_CYCLE()
      
  Const s_SHEET_OF_CODE As String = "Ciselnik"
  Const s_SHEET_OF_DATA As String = "Data"
  Const byt_START_ROW   As Byte = 2
      
  Dim as_DataforDelete() As Variant
  Dim l_LastRow  As Long, i As Long
  Dim j As Integer
  Dim t_Start As Date, t_End As Date
  
  ' vypnuti aktualizace obrazovky a prepctu vzorcu
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  t_Start = Time()
  
  ' nahraje do pole data pro smazanai
  With Sheets(s_SHEET_OF_CODE)
     as_DataforDelete = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)).Value
  End With
  
  With Sheets(s_SHEET_OF_DATA)
     ' cislo posledniho radku
     l_LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
     ' prochazim vsechny radky od posledniho k prvnimu
     For i = l_LastRow To byt_START_ROW Step -1
        For j = LBound(as_DataforDelete) To UBound(as_DataforDelete)
           ' pokud se data ve sloupci B rovnaji s hodnotou v poli bude
           ' radek smazan
           If .Cells(i, 2) = as_DataforDelete(j, 1) Then
              .Rows(i).Delete Shift:=xlShiftDown
           End If
        Next j
     Next i
    
  End With
  
  ' zapne aktualizaci obrazovky a prepoctu a zobrazi zpravu s dobou trvani
  t_End = Time()
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
  MsgBox "Hotovo!" & vbCrLf & "Celkový čas: " & FormatDateTime(t_End - t_Start)
  
End Sub


add2) Využití metody FIND a FINDnext Excelu a následného odstranění řádku
Je škoda že metoda Findnedokáže vrátit pole popř. oblast všech nalezených výskytu hodnoty se kterou by se dalo pracovat přímo. Takto musíme vyhledat nejdříve první výskyt hledané hodnoty, uložit si adresu a pak pomocí příkazu Findnext hledat další výskyty, které pomocí metody Union vkládáme do společné oblasti a porovnáváme zda se nenacházíme na prvním výskytu. Poté ukončit hledání a smazat všechny řádky najednou tak jak to je ukázáno v následujícím kódu, který trvá cca 9-10 sec.

'---------------------  Begin Comment -------------------------
' Comment:      Odstrani radky s daty kde se shoduji hodnoty ve '               sloupci B
'               s hodnotami na listu "Ciselnik"
'               Pouziva metody FIND Excelu a FINDNEXT pro '               nalezeni vsech
'               vyskytu hodnoty a nasledne je odstrani vsechny '               najednou.
'
' Arguments:    Without arguments
'
' Date             Author               Action
'--------------------------------------------------------------
' 10/21/2008    Premysl Lazecky         Created
Sub Delete_Choosen_Data_FIND()
      
  Const s_SHEET_OF_CODE As String = "Ciselnik"
  Const s_SHEET_OF_DATA As String = "Data"
  Const byt_START_ROW   As Byte = 2
      
  Dim as_DataforDelete() As Variant
  Dim r_Delete As Range, r_AreaDelete As Range
  Dim j As Integer
  Dim t_Start As Date, t_End As Date
  Dim firstAddress As String
  
  ' vypnuti aktualizace obrazovky a prepctu vzorcu
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  t_Start = Time()
  ' nahraje do pole data pro smazanai
  With Sheets(s_SHEET_OF_CODE)
     as_DataforDelete = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)).Value
  End With
  
  With Sheets(s_SHEET_OF_DATA)
     ' pro kazdou hodnotu v poli najde pomoci metody FIND a FINDNEXT vsechny vyskyty
     ' ty priradi do spolecne oblasti a nakonec najednou smaze
     For j = LBound(as_DataforDelete) To UBound(as_DataforDelete)
        ' vyhleda prvni vyskyt hodnoty ve sloupci B
        Set r_Delete = Columns(2).Find(What:=as_DataforDelete(j, 1), _
                                       LookIn:=xlValues)
        ' pokud hodnotu nasel prida ji do spolecne oblasti a ulozi si
        ' adresu prvni naleze bunky pro pozdejsi ukonceni v cyklu Do
        If Not r_Delete Is Nothing Then
            firstAddress = r_Delete.Address
            If r_AreaDelete Is Nothing Then
               Set r_AreaDelete = r_Delete
            Else
               Set r_AreaDelete = Union(r_AreaDelete, r_Delete)
            End If
              
            ' vyhleda dalsi vyskyt hodnoty a priradi jej do spolecne oblasti
            ' pomoci metody Union. Cela oblast pak bude odstranena
            ' kdyz narazi na prvni adresu kde zacinal ukonci ckylus Do
            Do
              Set r_Delete = Columns(2).FindNext(r_Delete)
              Set r_AreaDelete = Union(r_AreaDelete, r_Delete)
            Loop While Not r_Delete Is Nothing And r_Delete.Address <> firstAddress
                          
        End If
        ' smaze cele radky ve vsech oblastech
        If Not r_AreaDelete Is Nothing Then
           r_AreaDelete.EntireRow.Delete Shift:=xlShiftUp
           Set r_AreaDelete = Nothing
        End If
        
     Next j
  End With
  
  Set r_AreaDelete = Nothing: Set r_Delete = Nothing
  
  ' zapne aktualizaci obrazovky a prepoctu a zobrazi zpravu s dobou trvani
  t_End = Time()
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
  MsgBox "Hotovo!" & vbCrLf & "Celkový čas: " & FormatDateTime(t_End - t_Start)
  
End Sub


add3) ADODB a SQL dotaz
Nejlepší nakonec, využití ADODB se přímo nabízelo. Stačí poskládat v cyklu dotaz s klauzulí WHERE a spustit stroj MS Jet a získané data nakopírovat do nového listu. Tato metoda je hodně rychlá a na přiloženém sešitu s 11 tisíci záznamy netrvala déle než 3 vteřiny. Po spuštění tohoto kódu se mi ovšem podstatně zpomaluje celá aplikace Excel pomůže až úplně zavření a znovuotevření, bohužel zatím netuším proč k tomu to dochází.

'------------------  Begin Comment --------------------------
' Comment:      Odstrani radky s daty kde se shoduji hodnoty ve '               sloupci B
'               s hodnotami na listu "Ciselnik"
'               Pouziva ADODB a SQL dotazy.
' References:   Microsoft ActiveX Data Objects 2.8. Library
'
' Arguments:    Without arguments
'
' Date             Author               Action
'-------------------------------------------------------------
' 10/21/2008    Premysl Lazecky         Created
Sub Delete_Choosen_Data_SQL()
    
  Const s_SHEET_OF_CODE As String = "Ciselnik"
  Const s_SHEET_OF_DATA As String = "Data"
  ' nazev listu s znakem $ a nazev sloupce oddeleny teckou a znak nerovnoszi
  ' pro automaticke vytvoreni dotazu
  Const s_SQL_CLAUSE As String = "`Data$`.`Stock / SKU #`<>'"
      
  Dim as_DataforDelete() As Variant
  Dim j As Integer
  Dim t_Start As Date, t_End As Date
  Dim s_WorkbookPath As String, s_SQLWhere As String, s_Dotaz As String
  Dim cn As New ADODB.Connection
  Dim rs As New ADODB.Recordset

  ' vypnuti aktualizace obrazovky a prepctu vzorcu
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  t_Start = Time()
  
  s_WorkbookPath = ActiveWorkbook.FullName
  ' nahraje do pole data pro smazanai
  With Sheets(s_SHEET_OF_CODE)
     as_DataforDelete = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)).Value
  End With
  ' sestavi dotaz SQL v klouzuli WHERE hodnoty jsou oddeleny AND
  s_SQLWhere = vbNullString
  For j = LBound(as_DataforDelete) To UBound(as_DataforDelete)
     s_SQLWhere = s_SQLWhere & s_SQL_CLAUSE & as_DataforDelete(j, 1) & "') And ("
  Next j
  ' smaze posledni AND na konci
  s_SQLWhere = Left(s_SQLWhere, Len(s_SQLWhere) - 7)
  
  ' vytvori spojeni na ADODB
  cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
          "Data Source=" & s_WorkbookPath & ";" & _
          "Extended Properties=""Excel 8.0;"""

    'sestavení SQL dotazu
    'vyber veškerá data
     s_Dotaz = "SELECT * FROM `" & s_WorkbookPath & "`.`Data$` `Data$`" & Chr(13) & "" & Chr(10) & _
               "WHERE (" & s_SQLWhere & ");" 
    
     ' provede dotaz
     rs.Open s_Dotaz, cn, adOpenKeyset, adLockOptimistic
     rs.MoveFirst
    
     ' vlozi novy list a vlozi tam obsah recordsetu vc. zahlavi
     ActiveWorkbook.Sheets.Add
     Sheets(s_SHEET_OF_DATA).Rows(1).Copy
     ActiveSheet.Cells(1).PasteSpecial xlPasteValues
     Application.CutCopyMode = False
     Cells(2, 1).CopyFromRecordset rs
     Columns("A:D").AutoFit
  
     'ukončení spojení a uvolnění z paměti
     rs.Close
     Set rs = Nothing
  
  cn.Close
  Set cn = Nothing
  
  ' zapne aktualizaci obrazovky a prepoctu a zobrazi zpravu s dobou trvani
  t_End = Time()
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
  MsgBox "Hotovo!" & vbCrLf & "Celkový čas: " & FormatDateTime(t_End - t_Start)
  
End Sub


Další možnosti je použit Automatický filtr s cyklem ve kterém se budou měnit hodnoty z číselníku nebo taky rozšířený filtr. Zvláště automatický filtr je vhodný k prozkoumání.
Napadá Vás ještě nějaká možnost jak efektivně zpracovat tuto úlohu?
Soubor s daty