Excel count stejnych polozek Vyřešeno

[ansting]

Dobry den potreboval bych poradit mam sesit v excelu a na kazdem listu jednotlive PC a seznam SW a u nej v druhem sloupci licenci a potreboval bych pak na list Licence provest vypsani vsech SW jenz maji v licenci "nutna licence" a jeli to same na vice kartach pak siclo kolikrat se vyskytuji v sesitu je to mozne nejak provest pomoci macra????
Preden moc dekuji za jakoukoliv pomoc.

SWlist.xls

Predloha s 2 kartama skutecne ma asi 20

(195 KiB) Staženo 32 x

[Reklama]

[navstevnik]

Nize je procedura VBA, vloz v editoru VBA do modulu:

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(SCll.Value, LookIn:=xlValues)
            If Not TCll Is Nothing Then
              TCll.Offset(0, 1).Value = TCll.Offset(0, 1).Value + 1
            Else
              TNew.Offset(i, 0).Value = SCll.Value
              TNew.Offset(i, 1).Value = 1
              i = i + 1
            End If
          End With
        End If
      Next SCll
    End If
  Next Sht
End Sub

[ansting]

Velke diky presne tohle sme potreboval

[mike007]

navstevnik: Moc hezká práce

[navstevnik]

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