• DİKKAT

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

SÜTUNLARDAKİ VERİ SAYILARININ TOPLAMINI YAZDIRMA

E

Erdinç FIRTINA

Altın Üye
Katılım
14 Şubat 2007
Mesajlar
400
Excel Vers. ve Dili
excel 2003 türkçe
DEĞERLİ ÜYELER;

ÖRNEK DOSYAM İLİŞİKTE OLUP, AÇIKLAMALARI İLGİLİ SAYFADADIR.

YARDIMLARINIZ İÇİN ŞİMDİDEN ÇOK TEŞEKKÜRLER!!!!!
 

Ekli dosyalar

Buyurun.:cool:

DOSYAYI INDIR

Kod: 
Option Base 1
Sub ogrenci_59()
Dim sonsat As Long, liste(), myarr(), z As Object, i As Long, n As Long
Range("B2:D" & Rows.Count).ClearContents
Set z = CreateObject("scripting.dictionary")
sonsat = Cells(Rows.Count, "BD").End(xlUp).Row
liste = Range("BD2:BG" & sonsat).Value
ReDim myarr(1 To UBound(liste), 3)
For i = 1 To UBound(liste)
    If Not z.exists(liste(i, 1)) Then
        n = n + 1
        z.Add (liste(i, 1)), n
        myarr(n, 1) = liste(i, 1)
        myarr(n, 2) = 0
        myarr(n, 3) = 0
    End If
    If Left(liste(i, 4), 5) = "GİRDİ" Then
        myarr(z.Item(liste(i, 1)), 2) = myarr(z.Item(liste(i, 1)), 2) + 1
    ElseIf Left(liste(i, 4), 11) = "HİÇ GİRMEDİ" Then
        myarr(z.Item(liste(i, 1)), 3) = myarr(z.Item(liste(i, 1)), 3) + 1
    End If
Next
Erase liste
Range("B2").Resize(n, 3) = myarr
Erase myarr: Set z = Nothing
MsgBox "İşlem Bitti.", vbOKOnly + vbInformation, Application.UserName
End Sub
 

Ekli dosyalar

Son düzenleme:
Sayın Orion1 yardımlarınız için çok teşekkür ederim.
Benden kaynaklanan bir açıklama eksikliğimi gördüm. Örnek dosyamdaki açıklamamı ALT ALTA sayfasına yapmıştım. Dolayısıyla siz de ALT ALTA sayfasına göre kod yazdınız.

Rica etsem, söz konusu kodları AÇIKLAMA sayfasına göre uyarlayabilir misiniz?
Ayrıca BG sütununda ki (GİRDİ .......) yerine (BİRLİKTE) (HİÇ GİRMEDİ .......) yerine (KENDİ) gibi bir açıklama yazıp, kodlarda da (GİRDİ .......) yerine BİRLİKTE, (HİÇ GİRMEDİ .......) yerine (KENDİ) açıklaması ile değiştirdiğimde de hata veriyor. Bunun nedeni ne olabilir)

Yardımlarınız için şimdiden teşekkürler !!
 

Ekli dosyalar

Son düzenleme:
çıtır' Alıntı:
Benim hazırladığımda alternatif olsun.
Genişletmek için tıkla ...

Sayın çıtır,
öncelikle yardımlarınız için çok teşekkür ederim.

Alternatif olarak hazırladığınız dosyadaki ALT ALTA sf sında;
C sütununa BG sütunundaki "KENDİ" olanları sayıp ismin karşısına sayısını yazıyor.

Aynı zamanda BG sütununda "BİRLİKTE" olanlar var.

BG sütunundaki "BİRLİKTE" olanları da sayarak her ismin karşısına gelecek şekilde D sütununa yazdırabilir miyiz?

Bir de bu işlemleri "KARŞILAŞTIR" sayfasında yapabilir miyiz? (Yani veriler ALT ALTA sayfasından alınarak işlemleri "KARŞILAŞTIR" sayfasında yapmak)

Yardımlarınız için şimdiden teşekkürler!!!
 

Ekli dosyalar

Alternatif;

Kod: 
Option Explicit

Sub Ozet_Rapor()
    Dim S1 As Worksheet, S2 As Worksheet, Son As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("ALT ALTA")
    Set S2 = Sheets("KARŞILAŞTIRMA")
    
    S2.Range("A:D").Clear
    
    S1.Columns("BD:BD").Copy S2.Range("B1")
    S2.Range("B1:B65536").RemoveDuplicates Columns:=1, Header:=xlYes
    S2.Range("B1").Copy S2.Range("A1,C1,D1")
    S2.Range("A1") = "SIRA NO"
    S2.Range("C1") = "BİRLİKTE"
    S2.Range("D1") = "KENDİ"
    S2.Cells.Font.Name = "Calibri"
    S2.Cells.Font.Size = 11
    
    Son = S2.Cells(S2.Rows.Count, 2).End(3).Row
    S2.Range("A" & Son + 1 & ":A" & S2.Rows.Count).EntireRow.Delete
    
    With S2.Range("A2:A" & Son)
        .Formula = "=ROW()-1"
        .Value = .Value
    End With

    With S2.Range("C2:C" & Son)
        .Formula = "=COUNTIFS(" & S1.Range("BD:BD").Address(External:=True) & ",B2," & S1.Range("BG:BG").Address(External:=True) & ",""BİRLİKTE"")"
        .Value = .Value
    End With

    With S2.Range("D2:D" & Son)
        .Formula = "=COUNTIFS(" & S1.Range("BD:BD").Address(External:=True) & ",B2," & S1.Range("BG:BG").Address(External:=True) & ",""KENDİ"")"
        .Value = .Value
    End With
    
    S2.Range("A:A").HorizontalAlignment = xlCenter
    
    S2.Range("A1:D" & Son).Borders.LineStyle = 1
    S2.Cells.EntireColumn.AutoFit
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Korhan Ayhan' Alıntı:
Alternatif;

Kod: 
Option Explicit

Sub Ozet_Rapor()
    Dim S1 As Worksheet, S2 As Worksheet, Son As Long
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Set S1 = Sheets("ALT ALTA")
    Set S2 = Sheets("KARŞILAŞTIRMA")
   
    S2.Range("A:D").Clear
   
    S1.Columns("BD:BD").Copy S2.Range("B1")
    S2.Range("B1:B65536").RemoveDuplicates Columns:=1, Header:=xlYes
    S2.Range("B1").Copy S2.Range("A1,C1,D1")
    S2.Range("A1") = "SIRA NO"
    S2.Range("C1") = "BİRLİKTE"
    S2.Range("D1") = "KENDİ"
    S2.Cells.Font.Name = "Calibri"
    S2.Cells.Font.Size = 11
   
    Son = S2.Cells(S2.Rows.Count, 2).End(3).Row
    S2.Range("A" & Son + 1 & ":A" & S2.Rows.Count).EntireRow.Delete
   
    With S2.Range("A2:A" & Son)
        .Formula = "=ROW()-1"
        .Value = .Value
    End With

    With S2.Range("C2:C" & Son)
        .Formula = "=COUNTIFS(" & S1.Range("BD:BD").Address(External:=True) & ",B2," & S1.Range("BG:BG").Address(External:=True) & ",""BİRLİKTE"")"
        .Value = .Value
    End With

    With S2.Range("D2:D" & Son)
        .Formula = "=COUNTIFS(" & S1.Range("BD:BD").Address(External:=True) & ",B2," & S1.Range("BG:BG").Address(External:=True) & ",""KENDİ"")"
        .Value = .Value
    End With
   
    S2.Range("A:A").HorizontalAlignment = xlCenter
   
    S2.Range("A1:D" & Son).Borders.LineStyle = 1
    S2.Cells.EntireColumn.AutoFit
   
    Set S1 = Nothing
    Set S2 = Nothing
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Genişletmek için tıkla ...


Sayın Korhan AYHAN çok çok teşekkür ediyorum...
 
Erdinç FIRTINA' Alıntı:
Sayın Korhan AYHAN çok çok teşekkür ediyorum...
Genişletmek için tıkla ...

Sayın Korhan AYHAN,

Öncelikle yardımlarınız için tekrardan çok teşekkür ederim. Sizin düzenlemiş olduğunuz makrolarla "ALT ALTA" sayfasından "KARŞILAŞTIRMA" sayfasına aktarma işi tam da istediğim gibi olmuş.

Ancak, aktarılan verilerle yine bu sayfada formüller yardımıyla işlem yapmaya çalışıyorum ama işlem sonucunu vermiyor.

Ek dosyada ayrıntılı olarak açıklama yaptım. Eğer fırsatınız olur da bakabilirseniz çok mutlu olurum.

Yardımlarınız için şimdiden çok teşekkürler...
 

Ekli dosyalar

çıtır' Alıntı:
Rica ederim.Dönüş yaptığınız için teşekkür ederim.
Genişletmek için tıkla ...

Sayın çıtır,

Öncelikle yardımlarınız için tekrardan çok teşekkür ederim. Sizin düzenlemiş olduğunuz makrolarla "ALT ALTA" sayfasından "KARŞILAŞTIRMA" sayfasına aktarma işi tam da istediğim gibi olmuş.

Ancak, aktarılan verilerle yine bu sayfada formüller yardımıyla işlem yapmaya çalışıyorum ama işlem sonucunu vermiyor.

Ek dosyada ayrıntılı olarak açıklama yaptım. Eğer fırsatınız olur da bakabilirseniz çok mutlu olurum.

Yardımlarınız için şimdiden çok teşekkürler...
 

Ekli dosyalar

Dosyanız ektedir.:cool:

DOSYAYI INDIR

Kod: 
Option Base 1
Sub ogrenci_59()
Dim sonsat As Long, liste(), myarr(), z As Object, i As Long, n As Long
Dim sh As Worksheet
Set sh = Sheets("ALT ALTA")
Sheets("KARŞILAŞTIRMA").Select
Range("A2:D" & Rows.Count).ClearContents
Set z = CreateObject("scripting.dictionary")
sonsat = sh.Cells(Rows.Count, "BD").End(xlUp).Row
liste = sh.Range("BD2:BG" & sonsat).Value
ReDim myarr(1 To UBound(liste), 3)
For i = 1 To UBound(liste)
    If Not z.exists(liste(i, 1)) Then
        n = n + 1
        z.Add (liste(i, 1)), n
        myarr(n, 1) = liste(i, 1)
    End If
    If liste(i, 4) = "BİRLİKTE" Then
        myarr(z.Item(liste(i, 1)), 2) = myarr(z.Item(liste(i, 1)), 2) + 1
    ElseIf liste(i, 4) = "KENDİ" Then
        myarr(z.Item(liste(i, 1)), 3) = myarr(z.Item(liste(i, 1)), 3) + 1
    End If
Next
Erase liste
Range("B2").Resize(n, 3) = myarr
Range("A3").ClearContents
Range("A2").Value = 1
Range("A3").Value = 2
Range("A2:A3").AutoFill Range("A2:A" & n + 1)
Erase myarr: Set z = Nothing
MsgBox "İşlem Bitti.", vbOKOnly + vbInformation, Application.UserName
End Sub
 

Ekli dosyalar

Orion1' Alıntı:
Dosyanız ektedir.:cool:

DOSYAYI INDIR

Kod: 
Option Base 1
Sub ogrenci_59()
Dim sonsat As Long, liste(), myarr(), z As Object, i As Long, n As Long
Dim sh As Worksheet
Set sh = Sheets("ALT ALTA")
Sheets("KARŞILAŞTIRMA").Select
Range("A2:D" & Rows.Count).ClearContents
Set z = CreateObject("scripting.dictionary")
sonsat = sh.Cells(Rows.Count, "BD").End(xlUp).Row
liste = sh.Range("BD2:BG" & sonsat).Value
ReDim myarr(1 To UBound(liste), 3)
For i = 1 To UBound(liste)
    If Not z.exists(liste(i, 1)) Then
        n = n + 1
        z.Add (liste(i, 1)), n
        myarr(n, 1) = liste(i, 1)
    End If
    If liste(i, 4) = "BİRLİKTE" Then
        myarr(z.Item(liste(i, 1)), 2) = myarr(z.Item(liste(i, 1)), 2) + 1
    ElseIf liste(i, 4) = "KENDİ" Then
        myarr(z.Item(liste(i, 1)), 3) = myarr(z.Item(liste(i, 1)), 3) + 1
    End If
Next
Erase liste
Range("B2").Resize(n, 3) = myarr
Range("A3").ClearContents
Range("A2").Value = 1
Range("A3").Value = 2
Range("A2:A3").AutoFill Range("A2:A" & n + 1)
Erase myarr: Set z = Nothing
MsgBox "İşlem Bitti.", vbOKOnly + vbInformation, Application.UserName
End Sub
Genişletmek için tıkla ...


Çok teşekkür ederim Sayın Orion!
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst