Teke İndir Say ( Satır - Sütun )

[emreyılmaz]

Merhaba Arkadaşlar
Personelin Çalıştığı birim ve Unvan olarak satır sütunda norm kadroyu Makro ile saydırmak istiyorum..
Yardım ve önerileriniz için teşekkürler.

 

[Necdet]

Merhaba,
Aşağıdaki kodları "Kadro" sayfasının kod bölümüne kopyalayıp deneyiniz.

Private Sub CommandButton1_Click()

Dim i As Long
Dim j As Integer
Dim r As Long
Dim birim As Range
Dim unvan As Range

Application.ScreenUpdating = False

r = Sheets("Data").Cells(Rows.Count, "C").End(3).Row
Set birim = Sheets("Data").Range("C2:C" & r)
Set unvan = Sheets("Data").Range("B2:B" & r)

For i = 2 To Cells(Rows.Count, "A").End(3).Row
    Cells(i, "B") = Evaluate("=COUNTIF(Data!" & birim.Address & ",""" & Cells(i, "A") & """)")
    j = 3
    Do Until Cells(1, j) = ""
        Cells(i, j) = Evaluate("=SUMPRODUCT((Data!" & birim.Address & "=""" & Cells(i, "A") & """)*(Data!" & unvan.Address & "=""" & Cells(1, j) & """))")

        j = j + 1
    Loop
Next i

Application.ScreenUpdating = True

End Sub

 

[emreyılmaz]

Merhaba,
Aşağıdaki kodları "Kadro" sayfasının kod bölümüne kopyalayıp deneyiniz.

Private Sub CommandButton1_Click()

Dim i As Long
Dim j As Integer
Dim r As Long
Dim birim As Range
Dim unvan As Range

Application.ScreenUpdating = False

r = Sheets("Data").Cells(Rows.Count, "C").End(3).Row
Set birim = Sheets("Data").Range("C2:C" & r)
Set unvan = Sheets("Data").Range("B2:B" & r)

For i = 2 To Cells(Rows.Count, "A").End(3).Row
    Cells(i, "B") = Evaluate("=COUNTIF(Data!" & birim.Address & ",""" & Cells(i, "A") & """)")
    j = 3
    Do Until Cells(1, j) = ""
        Cells(i, j) = Evaluate("=SUMPRODUCT((Data!" & birim.Address & "=""" & Cells(i, "A") & """)*(Data!" & unvan.Address & "=""" & Cells(1, j) & """))")

        j = j + 1
    Loop
Next i

Application.ScreenUpdating = True

End Sub

Hocam Cevabınız için teşekkürler.
Benim öncelikli talebim. Tekrar eden birim ve Ünvanları tekli olarak satır - sütuna aldırmak

 

[DoğanD]

Merhaba,

Bu ihtiyacınız için Pivot Table birebir aslında. Araştırmanızı öneririm, faydalı olabilir.

 

[Necdet]

Hocam Cevabınız için teşekkürler.
Benim öncelikli talebim. Tekrar eden birim ve Ünvanları tekli olarak satır - sütuna aldırmak

Açıklamanızdan hiç bir şey anlamadım.
Örnek dosyanızda olması gerekeni de belirtseydiniz bu kadar yazışmaya gerek kalmazdı.

 

[emreyılmaz]

Data sayfasında Mevcut Personel listesini
Kadro sayfada A Sütununa Kurum ve Karşısına C1:...... satırına Ünvanları teke düşürerek yazdırmak istiyorum.

 

[Necdet]

aynı dosyayı göndermişsiniz,
ilçe sağlık müdürlüğünde doktor sayısı ne olmalı? onu yazın ve diğerlerinide kodları yazan da bunu dikkate alsın
benim anladığım ilçe sağlık müdürlüğünde şu kadar doktor bu kadar ebe var diye saymak, onu da kodlarda belirttim.

Fark ya da olmayan ne onu söyleyin.
Aynı dosyayı eklemek değil.

 

[Tevfik_Kursun]

Merhaba Arkadaşım,
Acaba bu dosyadaki gibi mi istemiştiniz?
Necdet Hocam, belki arkadaş bunu demek istemiştir. Hazırlanan örnek daha belirgin olsa daha kolay olacaktı. Olasılıklar peşindeyiz.

 

[emreyılmaz]

Merhaba Arkadaşım,
Acaba bu dosyadaki gibi mi istemiştiniz?
Necdet Hocam, belki arkadaş bunu demek istemiştir. Hazırlanan örnek daha belirgin olsa daha kolay olacaktı. Olasılıklar peşindeyiz.

İlginiz için teşekkürler..

Yapmak istediğim . Makro ile Ünvan ve Kurum isimlerinin teke indirilmesi.

 

[Tevfik_Kursun]

Yani aradığınız bu dosya değil mi?

 

[Necdet]

Yani aradığınız bu dosya değil mi?

Dalga geçtiğini sanıyorum artık ben :

 

[emreyılmaz]

Dalga geçtiğini sanıyorum artık ben :

Böyle düşünmenize üzüldüm.. Dosya içerisindeki açıklamalarda açıklayıcı anlattığımı zannediyorum.. Yanlış anlaşıldığı için özür dilerim.. Yıllardır formum Altın Üyesi, takipçisi olarak, Kimseyi kırmak üzmek veya dalga geçmek asla aklımdan geçmez..
Makro ile Kurum ve Ünvanları satır - sütun olarak teke indirilip saydırmak..
Yine de ilgi ve alakadan dolayı teşekkür ederim.

 

[Korhan Ayhan]

Alternatif olsun..

 

[Tevfik_Kursun]

Merhaba Arkadaşım,
Dosyanızda Data sayfasındaki verilere göre Kadro sayfasında olmasını istediklerinizi el ile doldurup bizimle paylaşın ki ne istediğinizi tam olarak anlayalım. Korhan Hocamın dosyası ile bizim paylaştıklarımız aynı.
Bizim de kimseyi kırmak gibi bir düşüncemiz yok. Ama yarım yamalak örnekle sonuç almaya çalışınca benzer sıkıntılar ortaya çıkıyor maalesef.
Lütfen dosyada ne olmasını istiyorsanız ona göre doldurun ki çözülsün. Hem sizin işiniz kolaylaşsın hem de biz yaptığımız çalışmadan zevk alalım.
İyi çalışmalar

 

[Necdet]

Korhan bey ,
bence sizde teke düşüremediniz

 

[emreyılmaz]

Alternatif olsun..

Teşekkürler Korhan bey tam istediğim bu... Sağ olun...

 

[Necdet]

Korhan beyden ben neyi farklı yaptım?
Sonuç olarak aynı.

 

[emreyılmaz]

Korhan beyden ben neyi farklı yaptım?
Sonuç olarak aynı.

Hocam Saygı ve salamlarımı sunuyorum..
Sizin modülde sadece süzerek Kurum ve Ünvarların toplamı alınıyor, Kurum ve Ünvarlar teke düşürülerek isim olarak şablona aktarılmıyordu..

Korhan bey ' in yazdığı kodla, Kurum İsimleri ve Ünvarlar teke düşürülüp ilgili Satır - Sütuna aktarılıp toplamları alınıyor.

İlgi ve alakanızdan dolayı sizlere şükranlarımı sunuyorum.

 

[Necdet]

Şimdi anladım.
Satır ve sütun başlıklarını da otomatik yazsın deseydiniz bu kadar yazışmaya gerek kalmazdı.
Sizin istediğiniz için makroya bile gerek yok, Pivot Tablo gayet güzel yapıyor.

 

[Necdet]

Ayrıca daha geçenlerde yazdığım dosyayı da paylaşayım.
Olayı başından anlasaydık doğrudan bu kodları verebilirdim.
Kendi örneğinizdeki sütun ve satır başlıklarını değiştirebilirsiniz.

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
    
Liste.UsedRange.ClearContents

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

Liste.Select

End Sub