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

Y

yakamozexcel

Altın Üye
Katılım
10 Aralık 2009
Mesajlar
23
Excel Vers. ve Dili
office 2003 Türkçe
Altın Üyelik Bitiş Tarihi
29-04-2028
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.
 
Son düzenleme:
H

Haluk

Özel Üye
Katılım
7 Temmuz 2004
Mesajlar
12,406
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
+
Google Sheets
+
JScript
Altın Üyelik Bitiş Tarihi
∞
Dizilerle uğraşmak yerine, alternatif olarak ADO-SQL kullanarak hazırlanan bir alternatif ektedir....


Test_SQL_Pivot.xlsm - 24 KB




.
 
Son düzenleme:
Y

yakamozexcel

Altın Üye
Katılım
10 Aralık 2009
Mesajlar
23
Excel Vers. ve Dili
office 2003 Türkçe
Altın Üyelik Bitiş Tarihi
29-04-2028
Haluk' Alıntı:
Dizilerle uğraşmak yerine, alternatif olarak ADO-SQL kullanarak hazırlanan bir alternatif ektedir....


Test_SQL_Pivot.xlsm - 24 KB



.
Genişletmek için tıkla ...
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
 
N

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,372
Excel Vers. ve Dili
Ofis 365 Türkçe
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
 
Y

yakamozexcel

Altın Üye
Katılım
10 Aralık 2009
Mesajlar
23
Excel Vers. ve Dili
office 2003 Türkçe
Altın Üyelik Bitiş Tarihi
29-04-2028
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
Genişletmek için tıkla ...
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.
 
Son düzenleme:
N

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,372
Excel Vers. ve Dili
Ofis 365 Türkçe
Eklediğim örnek dosyayı incelediniz mi?
Bi üzerinde çalışın onun derim.
 
Y

yakamozexcel

Altın Üye
Katılım
10 Aralık 2009
Mesajlar
23
Excel Vers. ve Dili
office 2003 Türkçe
Altın Üyelik Bitiş Tarihi
29-04-2028
Necdet' Alıntı:
Eklediğim örnek dosyayı incelediniz mi?
Bi üzerinde çalışın onun derim.
Genişletmek için tıkla ...
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.
 
N

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,372
Excel Vers. ve Dili
Ofis 365 Türkçe
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

Trilenium

Destek Ekibi
Destek Ekibi
Katılım
16 Eylül 2008
Mesajlar
1,122
Excel Vers. ve Dili
Microsoft Office 2019 English
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..

243893
 

Ekli dosyalar

N

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,372
Excel Vers. ve Dili
Ofis 365 Türkçe
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
 

Ekli dosyalar

beab05

beab05

Özel Üye
Katılım
19 Mart 2007
Mesajlar
1,418
Excel Vers. ve Dili
Office 2013
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.

Animation.gif
 
Y

yakamozexcel

Altın Üye
Katılım
10 Aralık 2009
Mesajlar
23
Excel Vers. ve Dili
office 2003 Türkçe
Altın Üyelik Bitiş Tarihi
29-04-2028
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
Genişletmek için tıkla ...
Çok teşekkür ederim. Seçenekli olması harika!
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst