Új hozzászólás Aktív témák

• #36038 Delila_1 veterán lenkei83 #36029

  Új Válasz 2017-08-25 10:18:18 #36038

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz lenkei83 #36029 üzenetére

  Az L-M oszlopba írja ki az egyes megnevezésekhez tartozó összegeket.

  Sub Kigyujtes()
Dim usor As Long

Columns(1).Copy Range("L1")
usor = Range("L" & Rows.Count).End(xlUp).Row
ActiveSheet.Range("L1:L" & usor).RemoveDuplicates Columns:=1
usor = Range("L" & Rows.Count).End(xlUp).Row

Range("M1:M" & usor) = "=sumif(A:A,L1,B:B)"
End Sub

• #36037 pigster senior tag lenkei83 #36029

  Új Válasz 2017-08-25 10:00:03 #36037

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  pigster

  senior tag

  válasz lenkei83 #36029 üzenetére

  Tools/References...-nél be kell jelölni a Microsoft Scripting Library-t a működéshez

  Function Gyujtes() As Scripting.Dictionary
Dim dict As Scripting.Dictionary

Dim myRange As Range
Dim sor As Long

Dim megnevezes As String
Dim ertek As Long

Set myRange = Range("A:B")
sor = 1

Set dict = New Scripting.Dictionary

megnevezes = myRange.Cells(sor, 1).Value
ertek = myRange.Cells(sor, 2).Value

Do While Not megnevezes = ""
If Not dict.Exists(megnevezes) Then
dict.Add megnevezes, ertek
Else
dict(megnevezes) = dict(megnevezes) + ertek
End If

sor = sor + 1
megnevezes = myRange.Cells(sor, 1).Value
ertek = myRange.Cells(sor, 2).Value
Loop
Set Gyujtes = dict
End Function



Sub Kiiras()
Dim dict As Scripting.Dictionary
Set dict = Gyujtes
Dim v As Variant

For Each v In dict.Keys
Rem persze a MsgBox helyett akármit lehet csinálni vele
MsgBox CStr(v) & " összesen: " & dict(v)
Next

End Sub

Új hozzászólás Aktív témák