• DİKKAT

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

Veri Saydırma

M

mest3651

Altın Üye
Katılım
5 Ocak 2006
Mesajlar
189
Merhaba. Arkadaşlar yapmak istediğimi dosyada anlatmaya çalıştım. Veri Saydırıp Sayfa 2 de ilgili hücrelere yazdırmak istiyorum.Saolun.
 

Ekli dosyalar

Merhaba,

ÇOKEĞERSAY fonksiyonu kullanarak özet tablonuzu oluşturabilirsiniz. B SINIFI sayfasındaki özet tabloyu inceleyin ve diğer sayfalara uygulayın.

İyi çalışmalar
 

Ekli dosyalar

Saolun. Excelin yeni sürümünde olduğu için bende gözükmedi. AD hatası veriyor.
 
Makro bilgim çok yüzeysel olduğundan, makro çözüm üretemeyeceğim.
 
Mehaba,

Makrolu çözüm,

Kod: 
Option Explicit
Sub tablo()
Dim a(), b(), c(), tbl(), d As Object
Dim s1 As Worksheet, s2 As Worksheet
Dim i As Long, y As Integer, Say As Long, j As Integer
Dim Aranan As String, deg As String
Dim Erkek_Sayi As Double, Kadin_Sayi As Double, S As Double
S = TimeValue(Now)
On Error Resume Next
Set s1 = Sheets("Sayfa1")
a = s1.Range("G5:K" & s1.Range("G" & Rows.Count).End(3).Row)
For j = 1 To Worksheets.Count
    If Sheets(j).Name <> "Sayfa1" Then
        Set d = CreateObject("scripting.dictionary")
        Set s2 = Sheets(j)
        Aranan = s2.Name
        For i = 1 To UBound(a)
            If a(i, 5) = "45 YAŞ VE ÜZERİ" Then a(i, 5) = "45+"
            If a(i, 5) = "22-44 YAŞ ARASI" Then a(i, 5) = "23-44"
            If a(i, 1) = Aranan Then
                a(i, 5) = Split(a(i, 5), " ")(0)
                deg = a(i, 5) & Trim(a(i, 2)) & Trim(a(i, 3))
                d(deg) = d(deg) + 1
            End If
        Next i
        b = s2.[B7:B10].Value
        c = s2.[F5:M6].Value
        ReDim tbl(1 To UBound(b) + 1, 1 To UBound(c, 2) + 3)
        For i = 1 To UBound(b)
            For y = 1 To UBound(c, 2) Step 2
                Erkek_Sayi = Val(d(b(i, 1) & c(1, y) & c(2, y)))
                Kadin_Sayi = Val(d(b(i, 1) & c(1, y) & c(2, y + 1)))
                tbl(i, 1) = tbl(i, 1) + Erkek_Sayi + Kadin_Sayi
                tbl(i, 2) = Erkek_Sayi
                tbl(i, 3) = Kadin_Sayi
                tbl(i, y + 3) = Erkek_Sayi
                tbl(i, y + 4) = Kadin_Sayi
            Next y
            For y = 1 To UBound(c, 2) + 3
            tbl(UBound(b) + 1, y) = tbl(UBound(b) + 1, y) + tbl(i, y)
            Next y
        Next i
        s2.[C7].Resize(UBound(b) + 1, UBound(c, 2) + 3) = tbl
    End If
Next j
MsgBox "İşlem Tamam." & vbLf & vbLf & CDate(TimeValue(Now) - S), vbInformation
End Sub
 

Ekli dosyalar

Ziynettin kardeşim çok teşekkür ederim. 16-17 yaş arası A1 sayfasına kişileri aktaramıyorum ona yardımcı olurmusunuz.
 

Ekli dosyalar

Selamlar,

Sayfa1 K Sütununda 16-17 yaş yoktur. Formüle onuda eklerseniz yapacaktır.
 
Hata aldığınız dosyayı ekler misiniz, dosya üzerinden bakalım.
 
Sayfa1 G sütununda A1 sonunda boşluk karakter olması.

Kod satırında kırmızı yazı ile ekleme yapıldı. Deneyiniz.

Kod: 
Sub tablo()
Dim a(), b(), c(), tbl(), d As Object
Dim s1 As Worksheet, s2 As Worksheet
Dim i As Long, y As Integer, Say As Long, j As Integer
Dim Aranan As String, deg As String
Dim Erkek_Sayi As Double, Kadin_Sayi As Double, S As Double
S = TimeValue(Now)
On Error Resume Next
Set s1 = Sheets("Sayfa1")
a = s1.Range("G5:K" & s1.Range("G" & Rows.Count).End(3).Row)
For j = 1 To Worksheets.Count
    If Sheets(j).Name <> "Sayfa1" Then
        Set d = CreateObject("scripting.dictionary")
        Set s2 = Sheets(j)
        Aranan = s2.Name
        For i = 1 To UBound(a)
            If a(i, 5) = "45 YAŞ VE ÜZERİ" Then a(i, 5) = "45+"
            If a(i, 5) = "22-44 YAŞ ARASI" Then a(i, 5) = "23-44"
            If [COLOR="red"]Trim([/COLOR]a(i, 1)[COLOR="red"]) [/COLOR]= Aranan Then
                a(i, 5) = Split(a(i, 5), " ")(0)
                deg = a(i, 5) & Trim(a(i, 2)) & Trim(a(i, 3))
                d(deg) = d(deg) + 1
            End If
        Next i
        b = s2.[B7:B10].Value
        c = s2.[F5:M6].Value
        ReDim tbl(1 To UBound(b) + 1, 1 To UBound(c, 2) + 3)
        For i = 1 To UBound(b)
            For y = 1 To UBound(c, 2) Step 2
                Erkek_Sayi = Val(d(b(i, 1) & c(1, y) & c(2, y)))
                Kadin_Sayi = Val(d(b(i, 1) & c(1, y) & c(2, y + 1)))
                tbl(i, 1) = tbl(i, 1) + Erkek_Sayi + Kadin_Sayi
                tbl(i, 2) = [COLOR="Red"]tbl(i, 2) +[/COLOR] Erkek_Sayi
                tbl(i, 3) = [COLOR="red"]tbl(i, 3) +[/COLOR] Kadin_Sayi
                tbl(i, y + 3) = Erkek_Sayi
                tbl(i, y + 4) = Kadin_Sayi
            Next y
            For y = 1 To UBound(c, 2) + 3
            tbl(UBound(b) + 1, y) = tbl(UBound(b) + 1, y) + tbl(i, y)
            Next y
        Next i
        s2.[C7].Resize(UBound(b) + 1, UBound(c, 2) + 3) = tbl
    End If
Next j
MsgBox "İşlem Tamam." & vbLf & vbLf & CDate(TimeValue(Now) - S), vbInformation
End Sub
 
#17 mesajdaki kodu denediniz mi?

Ekli dosyanızda denedim veriler geliyor.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst