vernel
Yeni Üye
- Katılım
- 12 Ağu 2021
- Mesajlar
- 321
- Çözümler
- 1
- Aldığı beğeni
- 127
- Excel V
- Office 2013 TR
Konu Sahibi
Selamlar, uzantısı B1 hücresinde yazılı kriter olan sayfaların veri özetini toplamak mümkün mü !
veyselemre'ye teşekkür ederim. 1 sütuna göre Harika bir kod paylaştı. Şimdi daha fazla sütunda veri olması halinde nasıl olabilir !
Sub test999()
Dim sh As Worksheet, krt As Byte, sG As Worksheet, _
son&, i&, ky$, itms, kys
Set sG = Sheets("Genel")
krt = sG.Range("E1").Value
With CreateObject("Scripting.Dictionary")
For Each sh In Sheets
If sh.Name Like ("*_" & krt) Then
son = sh.Cells(Rows.Count, 1).End(3).Row
If son > 1 Then
For i = 2 To son
ky = sh.Cells(i, 1).Value
.Item(ky) = .Item(ky) + sh.Cells(i, 2).Value
Next i
End If
End If
Next sh
sG.Range("A2:B" & Rows.Count).ClearContents
itms = .items
kys = .keys
sG.Range("A2:B2").Resize(UBound(kys) + 1).Value = WorksheetFunction.Transpose(Array(kys, itms))
sG.Range("A:B").Sort sG.Range("A2"), , , , , , , xlYes
End With
End Sub
veyselemre'ye teşekkür ederim. 1 sütuna göre Harika bir kod paylaştı. Şimdi daha fazla sütunda veri olması halinde nasıl olabilir !
Sub test999()
Dim sh As Worksheet, krt As Byte, sG As Worksheet, _
son&, i&, ky$, itms, kys
Set sG = Sheets("Genel")
krt = sG.Range("E1").Value
With CreateObject("Scripting.Dictionary")
For Each sh In Sheets
If sh.Name Like ("*_" & krt) Then
son = sh.Cells(Rows.Count, 1).End(3).Row
If son > 1 Then
For i = 2 To son
ky = sh.Cells(i, 1).Value
.Item(ky) = .Item(ky) + sh.Cells(i, 2).Value
Next i
End If
End If
Next sh
sG.Range("A2:B" & Rows.Count).ClearContents
itms = .items
kys = .keys
sG.Range("A2:B2").Resize(UBound(kys) + 1).Value = WorksheetFunction.Transpose(Array(kys, itms))
sG.Range("A:B").Sort sG.Range("A2"), , , , , , , xlYes
End With
End Sub
Ekli dosyalar
Bu konu çözüme ulaşmıştır yüklü dosyaları indirmek için Bronz üye olunuz.
Bu dosyayı indirmek için yetkiniz bulunmamaktadır.
