Mevcut Verilerden Benzersiz Tablo Yapma

[Astalavista58]

Merhabalar, herkese hayırlı günler dilerim. Ekteki verdiğim örnekte,


TextBox1'e yazdığım yıl değerini, Örneğin "2015"

E sütununda 2015 yılı olanları arayıp, 2015 yılında var olan AYLARI bulsun, "İstatistik" Sayfasında "A2" hücresine yapıştırsın.

"C" sütunundaki değerleri "İSTATİSTİK" sayfasında benzersiz olarak "B1" satıra yapıştırsın.

2015 yılında, Ocak ayında kaç tane "C" sütunundaki değerden varsa karşısına yazsın.

Örnek tablo ekteki dosyamda var yardımcı olabilir misiniz.

 

[veyselemre]

Option Explicit

Sub ozetle()
    Dim strCon$, strSql$, rs As Object, yil%, i%, son&, sutunSayisi%
    yil = 2015
 
    strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & ThisWorkbook.FullName & _
             "';Extended Properties=""Excel 12.0;HDR=YES;IMEX=1"";"

    Set rs = CreateObject("Adodb.RecordSet")

    strSql = " TRANSFORM COUNT(MEMLEKET) " & _
             " SELECT AYLAR FROM (SELECT DATEVALUE('01.' & FORMAT(TARİH,'MM.YYYY')) AS AYLAR, " & _
             " MEMLEKET FROM [ANASAYFA$B:E] " & _
             " WHERE YEAR(TARİH)=" & yil & ") " & _
             " GROUP BY AYLAR PIVOT MEMLEKET "
            
    rs.Open strSql, strCon
 
    With Sheets("İstatistik")
        .Select
        .Cells.Clear
        For i = 0 To rs.Fields.Count - 1
            Cells(1, i + 1).Value = rs.Fields(i).Name
        Next i
        If Not rs.EOF Then
            .Cells(2, 1).CopyFromRecordset rs
        End If
      
        son = .Cells(Rows.Count, 1).End(3).Row + 1
        sutunSayisi = rs.Fields.Count
        rs.Close
        With .Range(.Cells(son, 2), .Cells(son, sutunSayisi))
            .Select
            .FormulaR1C1 = "=SUM(R2C:R[-1]C)"
            .Value = .Value
            .Cells(1).Offset(, -1).Value = "TOPLAM"
            With .CurrentRegion
                .Borders.Color = rgbDarkBlue
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
            End With
        End With
 
        With .Range("A1").Resize(, sutunSayisi)
            .Select
            Union(.Offset(son - 1), Selection).Select
            Union(.Cells(1).Resize(son), Selection).Font.Bold = True
            With .Cells(2, 1).Resize(son - 2)
                .NumberFormat = "mmmm"
            End With
            .Cells(1).Value = yil
            .Cells(1).Select
        End With
        
    End With
        
    Set rs = Nothing

End Sub

Sub test()
    yil = 2015
    
    With Sheets("ANASAYFA")
        veri = .Range("A2:E" & .Cells(Rows.Count, 1).End(3).Row).Value
    End With

    sayMem = 2
    sayAy = 2
        
    Set sh = Sheets("İstatistik")
    sh.Cells.Clear
    sh.Range("A1").Value = yil
    
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(veri)
            
            If Year(veri(i, 5)) = yil Then
                MEMLEKET = "MEM|" & veri(i, 3)
                If Not .exists(MEMLEKET) Then
                    .Item(MEMLEKET) = sayMem
                    sh.Cells(1, sayMem).Value = veri(i, 3)
                    sayMem = sayMem + 1
                End If
                AY = "AY|" & Format(veri(i, 5), "MMM")
                If Not .exists(AY) Then
                    .Item(AY) = sayAy
                    sh.Cells(sayAy, 1).Value = UCase(Replace(Replace(Format(veri(i, 5), "MMMM"), "ı", "I"), "i", "İ"))
                    sayAy = sayAy + 1
                End If
                sat = .Item(AY)
                sut = .Item(MEMLEKET)
                sh.Cells(sat, sut).Value = sh.Cells(sat, sut).Value + 1
            End If
        Next i
    End With
    
    son = sh.Cells(Rows.Count, 1).End(3).Row + 1
    
    With sh.Cells(son, 2).Resize(, sayMem - 2)
        .FormulaR1C1 = "=SUM(R2C:R[-1]C)"
        .Value = .Value
        .Cells(1).Offset(, -1).Value = "TOPLAM"
    End With

    With sh.Cells(1, 1).Resize(, sayMem - 1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    
    With sh.Cells(2, 1).Resize(sayAy - 2)
        .Font.Bold = True
        .HorizontalAlignment = xlLeft
    End With
    
    With sh.Cells(son, 1).Resize(, sayMem)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    
    sh.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
    
    With sh.Cells(2, 2).Resize(sayAy - 2, sayMem - 2)
        .HorizontalAlignment = xlCenter
    End With
    With sh.Cells(1, 1).CurrentRegion
        .VerticalAlignment = xlCenter
    End With
    

End Sub

 

[Astalavista58]

Option Explicit

Sub ozetle()
    Dim strCon$, strSql$, rs As Object, yil%, i%, son&, sutunSayisi%
    yil = 2015

    strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & ThisWorkbook.FullName & _
             "';Extended Properties=""Excel 12.0;HDR=YES;IMEX=1"";"

    Set rs = CreateObject("Adodb.RecordSet")

    strSql = " TRANSFORM COUNT(MEMLEKET) " & _
             " SELECT AYLAR FROM (SELECT DATEVALUE('01.' & FORMAT(TARİH,'MM.YYYY')) AS AYLAR, " & _
             " MEMLEKET FROM [ANASAYFA$B:E] " & _
             " WHERE YEAR(TARİH)=" & yil & ") " & _
             " GROUP BY AYLAR PIVOT MEMLEKET "
          
    rs.Open strSql, strCon

    With Sheets("İstatistik")
        .Select
        .Cells.Clear
        For i = 0 To rs.Fields.Count - 1
            Cells(1, i + 1).Value = rs.Fields(i).Name
        Next i
        If Not rs.EOF Then
            .Cells(2, 1).CopyFromRecordset rs
        End If
    
        son = .Cells(Rows.Count, 1).End(3).Row + 1
        sutunSayisi = rs.Fields.Count
        rs.Close
        With .Range(.Cells(son, 2), .Cells(son, sutunSayisi))
            .Select
            .FormulaR1C1 = "=SUM(R2C:R[-1]C)"
            .Value = .Value
            .Cells(1).Offset(, -1).Value = "TOPLAM"
            With .CurrentRegion
                .Borders.Color = rgbDarkBlue
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
            End With
        End With

        With .Range("A1").Resize(, sutunSayisi)
            .Select
            Union(.Offset(son - 1), Selection).Select
            Union(.Cells(1).Resize(son), Selection).Font.Bold = True
            With .Cells(2, 1).Resize(son - 2)
                .NumberFormat = "mmmm"
            End With
            .Cells(1).Value = yil
            .Cells(1).Select
        End With
      
    End With
      
    Set rs = Nothing

End Sub

Sub test()
    yil = 2015
  
    With Sheets("ANASAYFA")
        veri = .Range("A2:E" & .Cells(Rows.Count, 1).End(3).Row).Value
    End With

    sayMem = 2
    sayAy = 2
      
    Set sh = Sheets("İstatistik")
    sh.Cells.Clear
    sh.Range("A1").Value = yil
  
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(veri)
          
            If Year(veri(i, 5)) = yil Then
                MEMLEKET = "MEM|" & veri(i, 3)
                If Not .exists(MEMLEKET) Then
                    .Item(MEMLEKET) = sayMem
                    sh.Cells(1, sayMem).Value = veri(i, 3)
                    sayMem = sayMem + 1
                End If
                AY = "AY|" & Format(veri(i, 5), "MMM")
                If Not .exists(AY) Then
                    .Item(AY) = sayAy
                    sh.Cells(sayAy, 1).Value = UCase(Replace(Replace(Format(veri(i, 5), "MMMM"), "ı", "I"), "i", "İ"))
                    sayAy = sayAy + 1
                End If
                sat = .Item(AY)
                sut = .Item(MEMLEKET)
                sh.Cells(sat, sut).Value = sh.Cells(sat, sut).Value + 1
            End If
        Next i
    End With
  
    son = sh.Cells(Rows.Count, 1).End(3).Row + 1
  
    With sh.Cells(son, 2).Resize(, sayMem - 2)
        .FormulaR1C1 = "=SUM(R2C:R[-1]C)"
        .Value = .Value
        .Cells(1).Offset(, -1).Value = "TOPLAM"
    End With

    With sh.Cells(1, 1).Resize(, sayMem - 1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
  
    With sh.Cells(2, 1).Resize(sayAy - 2)
        .Font.Bold = True
        .HorizontalAlignment = xlLeft
    End With
  
    With sh.Cells(son, 1).Resize(, sayMem)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
  
    sh.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
  
    With sh.Cells(2, 2).Resize(sayAy - 2, sayMem - 2)
        .HorizontalAlignment = xlCenter
    End With
    With sh.Cells(1, 1).CurrentRegion
        .VerticalAlignment = xlCenter
    End With
  

End Sub

Sayın veyselemre hocam elinize sağlık, çok teşekkür ederim, Allah sizden razı olsun. Çok güzel bir şekilde çalışıyor.