VBA'da Array (Diziler) kullanarak belli kriterlerdeki verilerin kaç adet olduğunu nasıl buluruz?

yakamozexcel · 24 Mart 2023

Selam Arkadaşlar engin bilgilerinizden faydalanmak istiyorum şimdiden nokta kadar faydası dokunanlar için teşekkür ederim.
Aşağıdakine benzer bir tablom var. VB kodunda Diziler kullanarak çözüm arıyorum.
Sayfa Adı; VERITABANI

SIRA NO	KIMLIK NO	ADI SOYADI	UNVANI	CALISTIGI BIRIM	KADRO DURUMU
1	1234	AHMET	DOKTOR	A BİRİMİ	KADROLU
2	1234	MEHMET	DOKTOR	B BİRİMİ	KADROLU
3	5466	AYŞE	MÜHENDİS	C BİRİMİ	GEÇİCİ
4	8484	FATMA	İŞÇİ	A BİRİMİ	SÖZLEŞMELİ
5	9898	ZEYNEP	MÜDÜR	C BİRİMİ	GEÇİCİ
6	9866	VELİ	MÜHENİS	A BİRİMİ	KADROLU
7	3658	UFUK	İŞÇİ	B BİRİMİ	GEÇİCİ

Bu şekilde devam eden verilerim var.

Sütun sayısı çok kısa olarak özetledim.
Not: sütün yerleri değişken olabilir ileri ki zamanlarda eklenmesi gerek duyulan sütunlar olabilir.
Yapmak istediğim;
SONUC sayfasında;
A2 Sütununda birimler aşağıya doğru benzersiz listelenecek.
B1 sütununda ise sağa doğru unvanların benzersiz şekilde sıralayıp
Daha sonra A BİRİMİNDE
Kaç tane Doktor, İşçi ve Mühendis var toplamını Macroda Array'leri kullanarak yazdırılmasını istiyorum.
Ayrıca BİRİMLERDE kaç tane KADROLU kaçtan GEÇİCİ var toplamları gerekiyor.

UNVAN DURUMU

	MÜDÜR	DOKTOR	MÜHENDİS	İŞÇİ
A BİRİMİ	0	1	1	1
B BİRİMİ	0	1	0	1
C BİRİMİ	1	0	1	0

KADRO DURUMU

	KADROLU	GEÇİCİ	SÖZLEŞMELİ
A BİRİMİ	2	0	1
B BİRİMİ	1	1	0
C BİRİMİ	0	2	0

Yardımlarınızı esirgemez iseniz çok memnum olurum. Kodları açıklayıcı bir şekilde paylaşır mısınız?
Mezara giden bilginin Hayrı olmaz.
Şimdiden Teşekkür ederim.

Haluk · 24 Mart 2023

Dizilerle uğraşmak yerine, alternatif olarak ADO-SQL kullanarak hazırlanan bir alternatif ektedir....

Test_SQL_Pivot.xlsm - 24 KB

.

yakamozexcel · 24 Mart 2023

Haluk' Alıntı:
Dizilerle uğraşmak yerine, alternatif olarak ADO-SQL kullanarak hazırlanan bir alternatif ektedir....

Test_SQL_Pivot.xlsm - 24 KB

.

Yardımlarınız için çok teşekkür ederim. Allah razı olsun.
Hocam Array ve For Next döngüsünde istememin sebebi;
1. MS Office'nin her versiyonun çalışabilir olması diğer kullanıcıların bilgisi olmayacağını düşünerek istedim.
2. Ram kullanarak büyük kayıtlarda hız açısından.
Eğer sizin için zahmet olmaz ise
For next döngüsünde Array kullanarak yapabilir misiniz?
Eklediğiniz dosyayı da kendim kullanacağım

Necdet · 25 Mart 2023

Merhaba,

Diziler gerçekten çok hızlı, ama "Not: sütün yerleri değişken olabilir ileri ki zamanlarda eklenmesi gerek duyulan sütunlar olabilir. " diyorsunuz.
Bu durumda dizi ile yazdığınız kod çöp olur.

O yüzden sabit sütunlu veriniz olsa işlem daha kolay olurdu.

Haluk beyin önerisi bu soru için daha mantıklı geldi bana da.

Üzerinde çalışmak isterseniz, 2 değişik örnek içeren dosya için TIKLAYINIZ

yakamozexcel · 25 Mart 2023

Necdet' Alıntı:
Merhaba,

Diziler gerçekten çok hızlı, ama "Not: sütün yerleri değişken olabilir ileri ki zamanlarda eklenmesi gerek duyulan sütunlar olabilir. " diyorsunuz.
Bu durumda dizi ile yazdığınız kod çöp olur.

O yüzden sabit sütunlu veriniz olsa işlem daha kolay olurdu.

Haluk beyin önerisi bu soru için daha mantıklı geldi bana da.

Üzerinde çalışmak isterseniz, 2 değişik örnek içeren dosya için TIKLAYINIZ

Hocam karşılaştırılacak Sütunları belirtiğimiz takdirde sorun olmaz gibi. Örneğin; Karşılaştırılacak Sütün 3 ve 10 dediğim de ve benim tarafımdan belirlendiğinde olur değil mi?
Yada Başlıkları tespit ederek. BİRİMLER ve ÜNVANLAR hangi sütunda ise ona göre gibi...
Örnek dosya için teşekkür ederim.

Necdet · 25 Mart 2023

Eklediğim örnek dosyayı incelediniz mi?
Bi üzerinde çalışın onun derim.

yakamozexcel · 25 Mart 2023

Necdet' Alıntı:
Eklediğim örnek dosyayı incelediniz mi?
Bi üzerinde çalışın onun derim.

Hocam
Sub SehirToplam()

'Microsoft Scripting Runtime Modülü Yüklenmeli (Ben bu yolu tercih ediyom)

Dim dic As New Dictionary
Dim arr As Variant
Dim i As Long
Dim j As Long
Dim k As Variant
Dim n As Integer

Range("J1").CurrentRegion.Offset(1).ClearContents
arr = Range("A1").CurrentRegion.Value

j = 0
For i = LBound(arr, 1) To UBound(arr)
k = arr(i, 1)
If Not dic.Exists(k) Then
j = j + 1
dic.Add k, j
arr(j, 2) = arr(i, 3)
Else
arr(dic.Item(k), 2) = arr(dic.Item(k), 2) + arr(i, 3)
End If
Next i

Range("J1").Resize(j, 2) = arr

End Sub

Burada şehirler farklı olduğu halde ilk aldığı ili yazıyor hepsine

Diğer kodda hata yok.

Necdet · 25 Mart 2023

Evet evet, küçük bir hata nelere mal oluyor

Kod şöyle olmalıydı, koddaki koyu satırı yazmayı unutmuşum.

Sub SehirToplam()

'Microsoft Scripting Runtime Modülü Yüklenmeli (Ben bu yolu tercih ediyom)

Dim dic As New Dictionary
Dim arr As Variant
Dim i As Long
Dim j As Long
Dim k As Variant
Dim n As Integer

Range("J1").CurrentRegion.Offset(1).ClearContents
arr = Range("A1").CurrentRegion.Value

j = 0
For i = LBound(arr, 1) To UBound(arr)
k = arr(i, 1)
If Not dic.Exists(k) Then
j = j + 1
dic.Add k, j
arr(j, 1) = arr(i, 1)
arr(j, 2) = arr(i, 3)
Else
arr(dic.Item(k), 2) = arr(dic.Item(k), 2) + arr(i, 3)
End If
Next i

Range("J1").Resize(j, 2) = arr

End Sub

Trilenium · 25 Mart 2023

Kod değilde alternatif olarak Pivot table ile 50.000 satırlık bir veriyi bir saniyeden kısa sürede görüntüleyebilirsiniz..

Necdet · 28 Mart 2023

Yine de sırf diziler ve koleksiyon kullanarak bir örnek hazırladım.
Bakın inceleyin beğnirseniz ve hakim olursanız kullanabilirsiniz.

Kod:

Public Sub PivotGibi()

Dim arrOku  As Variant, _
    arrLst  As Variant, _
    arrRow  As Variant, _
    arrCol  As Variant, _
    rngRow  As Range, _
    rngCol  As Range, _
    collRow As New Collection, _
    collCol As New Collection, _
    i       As Long, _
    j       As Long, _
    k       As Integer, _
    x       As Long, _
    hdfRng  As Range
    
On Error Resume Next
Set rngRow = Application.InputBox("Satırda Listelenecek Sütun Başlığını Seçiniz", "Satırdaki Veri Başlığı", Range("E1").Address, Type:=8)
On Error GoTo 0
If rngRow Is Nothing Then Exit Sub
    
On Error Resume Next
Set rngCol = Application.InputBox("Sütun Başlıkları Olacak Hücre?", "Sütun Başlıkları", Range("D1").Address, Type:=8)
On Error GoTo 0
If rngCol Is Nothing Then Exit Sub

arrOku = Veri.Range("A1").CurrentRegion.Value

For i = 2 To UBound(arrOku, 1)
    On Error Resume Next
    collRow.Add arrOku(i, rngRow.Column), arrOku(i, rngRow.Column)
    collCol.Add arrOku(i, rngCol.Column), arrOku(i, rngCol.Column)
    On Error GoTo 0
Next i

ReDim arrLst(1 To collRow.Count + 1, 1 To collCol.Count + 1)

'Başlıkları aktarılır
For i = 1 To collCol.Count
    arrLst(1, i + 1) = collCol.Item(i)
Next i

'1. Sütun Değerleri aktarılır
arrLst(1, 1) = rngRow.Value
For i = 1 To collRow.Count
    arrLst(i + 1, 1) = collRow.Item(i)
Next i

'veriler Yerleştiriliyor
For i = 2 To UBound(arrOku, 1)
    'Kaçıncı Sütuna Yerleştirilecek
    For x = 2 To UBound(arrLst, 2)
        If arrOku(i, rngCol.Column) = arrLst(1, x) Then
            k = x
            Exit For
        End If
    Next x
    'Kaçıncı Sütuna Yazılacak
    For x = 2 To UBound(arrLst, 1)
        If arrOku(i, rngRow.Column) = arrLst(x, 1) Then
            j = x
            Exit For
        End If
    Next x
    
    arrLst(j, k) = arrLst(j, k) + 1
Next i

'Veri.Range("H6").CurrentRegion.ClearContents
'Veri.Range("H6").Resize(UBound(arrLst, 1), UBound(arrLst, 2)) = arrLst

With Liste.Range("A1")
    .ClearContents
    .Resize(UBound(arrLst, 1), UBound(arrLst, 2)) = arrLst
End With
End Sub

Becerebildiysem Dosya Linki İçin TIKLAYINIZ

beab05 · 28 Mart 2023

Merhaba;

Alt toplamlarla istenilen sonuç olmaz mı? Aşağıdaki gibi mesela?

Not: Gif teki görüntüler burada da paylaştığım eklentime aittir ama şu an için çok tavsiye etmiyorum. Yeni versiyonu yolda.

yakamozexcel · 29 Nisan 2023

Necdet' Alıntı:

Yine de sırf diziler ve koleksiyon kullanarak bir örnek hazırladım.
Bakın inceleyin beğnirseniz ve hakim olursanız kullanabilirsiniz.

Kod:

Public Sub PivotGibi()

Dim arrOku  As Variant, _
    arrLst  As Variant, _
    arrRow  As Variant, _
    arrCol  As Variant, _
    rngRow  As Range, _
    rngCol  As Range, _
    collRow As New Collection, _
    collCol As New Collection, _
    i       As Long, _
    j       As Long, _
    k       As Integer, _
    x       As Long, _
    hdfRng  As Range
   
On Error Resume Next
Set rngRow = Application.InputBox("Satırda Listelenecek Sütun Başlığını Seçiniz", "Satırdaki Veri Başlığı", Range("E1").Address, Type:=8)
On Error GoTo 0
If rngRow Is Nothing Then Exit Sub
   
On Error Resume Next
Set rngCol = Application.InputBox("Sütun Başlıkları Olacak Hücre?", "Sütun Başlıkları", Range("D1").Address, Type:=8)
On Error GoTo 0
If rngCol Is Nothing Then Exit Sub

arrOku = Veri.Range("A1").CurrentRegion.Value

For i = 2 To UBound(arrOku, 1)
    On Error Resume Next
    collRow.Add arrOku(i, rngRow.Column), arrOku(i, rngRow.Column)
    collCol.Add arrOku(i, rngCol.Column), arrOku(i, rngCol.Column)
    On Error GoTo 0
Next i

ReDim arrLst(1 To collRow.Count + 1, 1 To collCol.Count + 1)

'Başlıkları aktarılır
For i = 1 To collCol.Count
    arrLst(1, i + 1) = collCol.Item(i)
Next i

'1. Sütun Değerleri aktarılır
arrLst(1, 1) = rngRow.Value
For i = 1 To collRow.Count
    arrLst(i + 1, 1) = collRow.Item(i)
Next i

'veriler Yerleştiriliyor
For i = 2 To UBound(arrOku, 1)
    'Kaçıncı Sütuna Yerleştirilecek
    For x = 2 To UBound(arrLst, 2)
        If arrOku(i, rngCol.Column) = arrLst(1, x) Then
            k = x
            Exit For
        End If
    Next x
    'Kaçıncı Sütuna Yazılacak
    For x = 2 To UBound(arrLst, 1)
        If arrOku(i, rngRow.Column) = arrLst(x, 1) Then
            j = x
            Exit For
        End If
    Next x
   
    arrLst(j, k) = arrLst(j, k) + 1
Next i

'Veri.Range("H6").CurrentRegion.ClearContents
'Veri.Range("H6").Resize(UBound(arrLst, 1), UBound(arrLst, 2)) = arrLst

With Liste.Range("A1")
    .ClearContents
    .Resize(UBound(arrLst, 1), UBound(arrLst, 2)) = arrLst
End With
End Sub

Becerebildiysem Dosya Linki İçin TIKLAYINIZ

Çok teşekkür ederim. Seçenekli olması harika!

yakamozexcel · 29 Nisan 2023

Trilenium' Alıntı:
Kod değilde alternatif olarak Pivot table ile 50.000 satırlık bir veriyi bir saniyeden kısa sürede görüntüleyebilirsiniz..

Ekli dosyayı görüntüle 243893

dosyayı indiremiyorum. Altın üyelik yaptım fakat onaylanmadı halen

Trilenium · 1 Mayıs 2023

yakamozexcel' Alıntı:
dosyayı indiremiyorum. Altın üyelik yaptım fakat onaylanmadı halen

İndir Deneme

Dosyayı indir Deneme

dosya.co

VBA'da Array (Diziler) kullanarak belli kriterlerdeki verilerin kaç adet olduğunu nasıl buluruz?

yakamozexcel

Haluk

Özel Üye

yakamozexcel

Necdet

Moderatör

yakamozexcel

Necdet

Moderatör

yakamozexcel

Necdet

Moderatör

Trilenium

Destek Ekibi

Ekli dosyalar

Necdet

Moderatör

Ekli dosyalar

beab05

Özel Üye

yakamozexcel

yakamozexcel

Trilenium

Destek Ekibi

İndir Deneme