Soru MsgBox ile İcmal (Toplam) Almak

[TURKOLOG]

Herkese Merhaba,
Bir excel dosyam var . Bu excel sayfamın KONTROL sayfasının B sütununda rütbeler sıralı bir şekilde yazıyor . Bu rütbeler arttıkça veya oluştukça KONTROL sayfası B sütnuna ekleniyor.

VERİ sayfasında personel bilgileri var VERİ sayfası E sütununda ise (Kontrol sayfası B sütunundan veri çekiyor) güncel personele ait rütbeler mevcut.

VBA ile Veri sayfasındaki E2: E son dolu satıra kadar sütunundaki rütbelere göre msgBox şeklinde icmal almak istiyorum .

MSGBOX
BİLGİLENDİRME
Misal :

1.Sınıf Emniyet Müdürü :0
2.Sınıf Emniyet Müdürü :1
3.Sınıf Emniyet Müdürü :1
4.Sınıf Emniyet Müdürü :1
Emniyet Amiri :4
Başkomiser :8
Komiser :6
Komiser Yardımcısı :12
Kıdemli Başpolis Memuru :4
Başpolis Memuru :8
Polis Memuru :102
Çarşı ve Mahalle Bekçisi :36
Sivil Memur :302
Teknisyen :78
Teknisyen Yardımcısı :36
Diğer :0

şeklinde msgbox şeklinde uyarı verse . Bu msgboxtaki yazıları kopyalayabilmem mümkün mü. Yardım edebilecek varsa çok sevinirim.

 

[muratboz06]

ZZ ve AAA sütunları yardımcı olarak kullanılmıştır. Bu sütunlarda veri var ise başka sütunları kullanabilirsiniz.

Sub UnvanlarveSayilari()
Columns("ZZ:AAA").ClearContents
Dim Unvan As Range
Dim kaynak As Worksheet
Set kaynak = Worksheets("VERİ")
kaynak.Activate
With ActiveSheet
.Range("e2", .Range("e2").End(xlDown)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("ZZ1"), Unique:=True
.Range("ZZ1").Delete Shift:=xlShiftUp
.Range("ZZ1", .Range("ZZ1").End(xlDown)).Select
sonSatır = Selection.Rows.Count
For Each Unvan In Selection
Unvan.Offset(0, 1).Value = WorksheetFunction.CountIf(Range("E:E"), Unvan.Value)
Next Unvan
Range("ZZ1").Select
MsgBox "Unvanlar ve değerleri kopyalanacaktır."
Range("ZZ1:AAA" & sonSatır).Copy
End With

End Sub

 

[TURKOLOG]

ZZ ve AAA sütunları yardımcı olarak kullanılmıştır. Bu sütunlarda veri var ise başka sütunları kullanabilirsiniz.

Sub UnvanlarveSayilari()
Columns("ZZ:AAA").ClearContents
Dim Unvan As Range
Dim kaynak As Worksheet
Set kaynak = Worksheets("VERİ")
kaynak.Activate
With ActiveSheet
.Range("e2", .Range("e2").End(xlDown)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("ZZ1"), Unique:=True
.Range("ZZ1").Delete Shift:=xlShiftUp
.Range("ZZ1", .Range("ZZ1").End(xlDown)).Select
sonSatır = Selection.Rows.Count
For Each Unvan In Selection
Unvan.Offset(0, 1).Value = WorksheetFunction.CountIf(Range("E:E"), Unvan.Value)
Next Unvan
Range("ZZ1").Select
MsgBox "Unvanlar ve değerleri kopyalanacaktır."
Range("ZZ1:AAA" & sonSatır).Copy
End With

End Sub

Sayın @muratboz06 çalışmanız güzel emeğinize sağlık . Ama Şöyle bir şey yapmamız mümkün mü
1Bu şekilde çalışsın kopyalama işlemi yapmak için hazır olsun , Fakat Tüm Rütbeler sıralı gelse sadece olan rütbeler ve sayıları değilde tüm rütbeler Kontrol sayfasından sıralı gelse
2. ilk maddeye ek olarak bir userformda labelde ekrana ayrıca gelse çünkü ilk maddedeki haliyle başka bir excel word texte alabilirim bu özellik harika. Ama ben bir de acil anlar için hemen userformda labelde de görmek istiyorum. Bu şekilde kullandığım excel sayfam gizli aktif değil ondan dolayı extra userformda görmek isitiyorum.
3. Tüm rütbelerin sıralı gelmesini şu yüzden istiyorum. Bende 2. sınıf Emniyet Müdürü var ama sıralama yaptığımda hiç göstermiyor.
kodu revize ederseniz çok sevinirin.

 

[TURKOLOG]

Private Sub İcmal_Click()
Columns("B:C").ClearContents
Dim Unvan As Range
Dim kaynak As Worksheet
Set kaynak = Worksheets("VERİ")
kaynak.Activate
With Sayfa8
.Range("E2", .Range("E2").End(xlDown)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("B3"), Unique:=True
.Range("B3").Delete Shift:=xlShiftUp
.Range("B3", .Range("B3").End(xlDown)).Select
SonSatır = Selection.Rows.Count
For Each Unvan In Selection
Unvan.Offset(0, 1).Value = WorksheetFunction.CountIf(Range("E:E"), Unvan.Value)
Next Unvan
Range("B3").Select
MsgBox "Unvanlar ve değerleri kopyalanacaktır."
Range("B3:C" & SonSatır).Copy
End With
End Sub

Kodunuzu bu hale çevirdim gerçek değer ve hücrelere bir yerde hata yaptım sanırım çalışmadı

 

[TURKOLOG]

Private Sub İcmal_Click()
Columns("B:C").ClearContents
Dim Unvan As Range
Dim kaynak As Worksheet
Set kaynak = Worksheets("VERİ")
kaynak.Activate
With Sayfa8
.Range("E2", .Range("E2").End(xlDown)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("B3"), Unique:=True
.Range("B3").Delete Shift:=xlShiftUp
.Range("B3", .Range("B3").End(xlDown)).Select
SonSatır = Selection.Rows.Count
For Each Unvan In Selection
Unvan.Offset(0, 1).Value = WorksheetFunction.CountIf(Range("E:E"), Unvan.Value)
Next Unvan
Range("B3").Select
MsgBox "Unvanlar ve değerleri kopyalanacaktır."
Range("B3:C" & SonSatır).Copy
End With
End Sub

Kodunuzu bu hale çevirdim gerçek değer ve hücrelere bir yerde hata yaptım sanırım çalışmadı

Ben yaptığı kopyalamayı VERİ sayfasının ZZ:AAA aralığına değil ayrıca İCMAL sayfasında B3:C3 den itibaren yapıştırmasını istiyorum. B3:C3 aralığını temizleyip yapıştırmasını istiyorum.

 

[muratboz06]

Yukarıda belirttiniz rütbe isimleri sabit mi birde rütbe sıralaması yukarıdaki gibi mi olacak. Örnek veri ve icmal sayfası paylaşıp görmek istediğiniz neticeyide belirtirseniz yardımcı olabilirim. Dosyayı dosya.tc adresine yükleyebilirsiniz.

 

[TURKOLOG]

Evet rütbe isimleri sabit ve kontrol sayfasındaki sıraya göre. Yeni 1 rütbe eklenirse kontrol sayfasındaki siraya eklenecek. Örnek dosyayı hazırlayıp paylaşıyorum birazdan

 

[TURKOLOG]

Sayın @muratboz06
Dosyayı ekledim . Rütbe sıralaması yapacak. Bir de rütbeye göre aktif pasif sıralaması yapacak. Aktif pasif verileri kontrol sayfasındadır. Veri sayfasında N sütunana göre Aktif pasif sıralaması yapacak ama. Örneği ekledim.
İcmal Dosyası İndirme Linki

 

[TURKOLOG]

İcmal Linki
Sayın @muratboz06
Dosyanın son halini yükledim

 

[muratboz06]

Düzeltme.

 

[TURKOLOG]

Düzeltme.

Sayın @muratboz06
9. Mesajda dosyanın son halini yükledim

Tablodaki sıfir "0" degerlerleri toplamada sorun olmayacak ise boş da görünebilir.

 

[muratboz06]

İcmal sayfasına özet döktürdüm, makroya ihtiyaç yoktur. Yeni bir rütbeyi ekledğinizde üst satırdaki formülleri kopyalarsınız.

İndir Rütbe sicile Göre Sıralama

Dosyayı indir Rütbe sicile Göre Sıralama

dosya.co

 

[TURKOLOG]

Sayın @muratboz06
Emeğinize sağlık acil olarak işimi görecek bu dosya. Çok teşekkür ederim size çok zahmet verdim. Yaptığınız çalışma işlemi makroya dökene kadar beni fazlasıyla rahatlatacaktır. Tekrar tekrar teşekkür ederim.
Ama dediğim gibi makro ile olursa kontrol sayfasında yazılan / yazılacak rütbelere göre anlık kendi çekip verecek böylesi ilerleyen zaman için daha pratik olacak benim için.

 

[TURKOLOG]

Makro ile Çözümü. Birilerine lazım olur diye yüklüyorum