On Fri, 28 Jan 2011 09:08:54 +0200, "Mindaugas" <nera@mailo.com> wrote:

>Va cia tai ko reikia, didelis ACIU, bet ....  su mavo kukliom ziniom nepavyko perprasti kas, kur kaip ir kodel :((( o perprasti noretusu, kad galeciau ir kitokio tipo lentelej pritaikyti, ar elementariai iterpti stulpeli ar eilute...
>
Bandau pridėti komentarus ;)

Type rws ' aprašo būsimos lentelės tipą
  a As String
  b As String
  c As Variant
End Type

Sub SumUnique()
  Dim LastRow As Long, MyRow As Long ' Last Row - paskutinė duomenų eilutė, MyRow - skaičiuojama
  Dim duom1 As String, duom2 As String, duom3 ' - nuskaitomi duomenys
  Dim Result() As rws ' Lentelė, kurią procedūros pabaigoje išvedame į ekraną
  Dim n, i, Prideti As Boolean 'pagalbiniai kintamiejai
  Application.ScreenUpdating = False ' išjungia ekrano perpiešimą ( teoriškai turėtų būti greičiau atliekama procedūra)
  n = 2
  Prideti = True
  LastRow = Range("A" & Rows.Count).End(xlUp).Row suranda paskutinę lentelės eilutę. Atitinka, jei pasižymėtai paskutinę Sheeto celę
(A65536), po to paspaustai "End" ir rodyklę į viršų
  For MyRow = 2 To LastRow ' nuo antros iki paskutinės eilutės
    duom1 = Cells(MyRow, 1).Value ' Nuskaito reikšmes A, B ir C stulpeliuose
    duom2 = Cells(MyRow, 2).Value
    duom3 = Val(Cells(MyRow, 3).Value) ' Val funkcija paverčia skaičiumi tekstinį įrašą. Jei bus "123A" gausi 123, jei "A123" ar "AA" tai 0 
    If MyRow = 2 Then 'jei eilutės nr. 2
      ReDim Result(2 To 2) 'aktyvuoja lentelę Result
      Result(2).a = duom1 ' ir surašo antros eilutės duomenis
      Result(2).b = duom2
      Result(2).c = duom3
    Else ' jei eilutės numeris ne 2
      For i = 2 To n ' tikrina A ir B stulpelio reikšmes su lentelės reikšmėm
        If (duom1 = Result(i).a) And (duom2 = Result(i).b) Then' jei randa sutampančius
          Result(i).c = Result(i).c + duom3 ' tai priplisuoja C stulpelio reikšmę prie esamos
          Prideti = False ' pakeičia kintamojo Prideti reikšmę (nebus naujos eilutės lentelėje )
          Exit For ' nutraukia procedūrą For (nebūtina eilutė, truputį pagreitina darbą)
        End If
      Next i
        If Prideti = True Then 'jei nebuvo rasta sutapimų
          n = n + 1
          ReDim Preserve Result(2 To n) 'prideda eilutę Result lentelėje
          Result(n).a = duom1 ' ir surašo nuskaitytas reikšmes
          Result(n).b = duom2
          Result(n).c = duom3
        End If
        Prideti = True ' pakeičia Prideti reikšmę į pradinę
    End If
  Next MyRow
  Range("A2:C" & LastRow).Delete ' ištrina duomenų lentelę
  For MyRow = 2 To n ' ir surašo į tą vietą naujus duomenis iš Result()
    Cells(MyRow, 1).Value = Result(MyRow).a
    Cells(MyRow, 2).Value = Result(MyRow).b
    Cells(MyRow, 3).Value = Result(MyRow).c
  Next MyRow
  Application.ScreenUpdating = True ' Įjungia ekrano perpiešimą
End Sub ' Ir viskas