Nektere nazvy SW zacinaji mezerou, coz bylo osetreno nepouzitim parametru LokkAt v metode Find, ale nektere jsou shodne s casti delsiho nazvu, cehoz jsem si nevsiml, takze tyto jsou nespravne prirazeny. Nize je opravena verze odstranujici mezery na zacatku (konci), vyhledavajici cele nazvy a doplnena o setrideni soupisu:
Kód: Vybrat vše
Option Explicit
Sub SWNutnaLicence()
Dim Sht As Worksheet, SBlok As Range, SCll As Range
Dim TSht As Worksheet, TBlok As Range, TCll As Range, TNew As Range, i As Long
i = 0
Set TSht = Worksheets("licence")
Set TBlok = TSht.UsedRange
TBlok.Offset(1, 0).ClearContents
Set TNew = TSht.Range("a2")
For Each Sht In ActiveWorkbook.Worksheets
If Sht.Name <> "Licence" Then
Set SBlok = Range(Sht.Range("A24"), Sht.Range("A24").End(xlDown))
For Each SCll In SBlok
If SCll.Offset(0, 3).Value = "Nutna licence" Then
Set TBlok = Range(TSht.Range("A2"), TSht.Range("A2").End(xlDown))
With TBlok
Set TCll = .Find(Trim(SCll.Value), LookIn:=xlValues, LookAt:=xlWhole)
If Not TCll Is Nothing Then
TCll.Offset(0, 1).Value = TCll.Offset(0, 1).Value + 1
Else
TNew.Offset(i, 0).Value = Trim(SCll.Value)
TNew.Offset(i, 1).Value = 1
i = i + 1
End If
End With
End If
Next SCll
End If
Next Sht
Set TBlok = Range(TSht.Range("A2"), TSht.Range("B2").End(xlDown))
TBlok.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End Sub