• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Soru MsgBox ile İcmal (Toplam) Almak

T

TURKOLOG

Altın Üye
Katılım
13 Kasım 2008
Mesajlar
745
Excel Vers. ve Dili
2016 64 TR
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.
 

Ekli dosyalar

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
 
muratboz06' Alıntı:
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
Genişletmek için tıkla ...
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.
 
Kod: 
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' Alıntı:
Kod: 
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ı
Genişletmek için tıkla ...
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.
 
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.
 
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
 
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
 

Ekli dosyalar

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.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst