-
Fototrend
A Microsoft Excel topic célja segítséget kérni és nyújtani Excellel kapcsolatos problémákra.
Kérdés felvetése előtt olvasd el, ha még nem tetted.
Új hozzászólás Aktív témák
-
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[ Szerkesztve ]
FIGYELEM! A többszázezres Samsung okostévék kéretlen reklámokat tolnak az arcodba.
-
Delila_1
Topikgazda
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 SubProgramozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.
Új hozzászólás Aktív témák
- Háztartási gépek
- SkyShowtime
- Székesfehérvár és környéke adok-veszek-beszélgetek
- World of Tanks - OFF topic
- Trollok komolyan
- Otthoni hálózat és internet megosztás
- A Watch7-tel debütálhat a Samsung vércukormérője
- Telekom TV SmartBox: szolgáltatói set-top box alacsony korlátokkal
- Autós topik
- D1Rect: Nagy "hülyétkapokazapróktól" topik
- További aktív témák...
- Steames kulcsok jó áron eladóak!
- Bontatlan - BATTLEFIELD 1 Collectors Edition - Játékszoftver nélkül
- Eredeti Windows, telepítéssel! Digital Doctor Számítógép Szerviz
- World of Warcraft Shadowlands Collectors edition EU EN
- Eredeti Microsoft termékek - MEGA Akciók! Windows, Office Pro Plus, Project Pro, Visio Pro stb.
- Diablo IV eladó
- Eladó PC Játékok Bontott és Bontatlan csomagolásban
- Eredeti Windows 10, Windows 11, Office Akció: Office 2021, Office 2019, Office 2016 csak Retail
- Microsoft Office 2019 Otthoni és vállalati verzió (PC / MAC)
- Total War: WARHAMMER II - The Warden & The Paunch (DLC) Epic Games Key GLOBAL