Soru Hücreyi yatay ve dikey ortalama

P

pasha22

Katılım
27 Ocak 2012
Mesajlar
78
Excel Vers. ve Dili
2016 Türkçe
Altın Üyelik Bitiş Tarihi
27.05.2022
Kod: 
Sub yeni2()

    Dim veri(120), detay(120, 5, 6), aranan(24, 5) As Variant

    deger = 0
    satir = 0
   
    Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
   
    For i = 8 To 42 Step 7
        Sayfa18.Range("B" & i & ":X" & i + 4).Clear
    Next i

    For i = 3 To 42 Step 7
        For ii = 1 To 24 Step 6
            For ia = 0 To 4 ' kişi
                veri(deger) = Sayfa17.Cells(i + ia, ii)
                For ib = 0 To 4 ' sütun değerleri
                    detay(deger, ib, 0) = Sayfa17.Cells(i + ia, ii + ib + 1)  'isim alındı
                    detay(deger, ib, 1) = Sayfa17.Cells(i + ia, ii + ib + 1).Font.Bold ' yazı kalın mı
                    detay(deger, ib, 2) = Sayfa17.Cells(i + ia, ii + ib + 1).Font.Italic ' yazı italik mi
                    detay(deger, ib, 3) = Sayfa17.Cells(i + ia, ii + ib + 1).Font.Color ' yazı rengi
                    detay(deger, ib, 4) = Sayfa17.Cells(i + ia, ii + ib + 1).Font.Name ' yazı ailesi
                    detay(deger, ib, 5) = Sayfa17.Cells(i + ia, ii + ib + 1).Font.Size  ' yazı boyutu
                    detay(deger, ib, 6) = Sayfa17.Cells(i + ia, ii + ib + 1).Interior.Color ' arkaplan rengi
              
                Next ib
                deger = deger + 1
            Next ia
        Next ii
    Next i
   
    For i = 2 To Sayfa14.Cells(Rows.Count, 1).End(3).Row
        If CDate(Sayfa14.Cells(i, 1)) = CDate(Sayfa18.Cells(1, "t")) Then
            satir = i
            Exit For
        End If
    Next i
   
   
    If satir = "" Then

        Exit Sub
    End If
   
    deger = 0
    For i = 2 To 100 Step 5
        aranan(deger, 0) = Sayfa14.Cells(1, i)
        For ii = 0 To 4
            For ia = 0 To 120
                If CStr(Sayfa14.Cells(satir, i + ii)) = CStr(veri(ia)) Then
                    aranan(deger, ii + 1) = ia
                    ia = 120
                End If
            Next ia
        Next ii
        deger = deger + 1
    Next i
   
    For i = 7 To 40 Step 7
        For ii = 2 To 24 Step 6
            For ia = 0 To 24
                If CStr(Sayfa18.Cells(i, ii)) = CStr(aranan(ia, 0)) Then
                    For ib = 1 To 5 ' bulunan alanın alt alta isimleri getirme
                        For ic = 0 To 4 ' bulunan alanın sütunları arasında gezinti
                            If IsEmpty(aranan(ia, ib)) Then GoTo devam
                            Sayfa18.Cells(i + ib, ii + ic) = detay(aranan(ia, ib), ic, 0)
                            Sayfa18.Cells(i + ib, ii + ic).Font.Bold = detay(aranan(ia, ib), ic, 1)
                            Sayfa18.Cells(i + ib, ii + ic).Font.Italic = detay(aranan(ia, ib), ic, 2)
                            Sayfa18.Cells(i + ib, ii + ic).Font.Color = detay(aranan(ia, ib), ic, 3)
                            Sayfa18.Cells(i + ib, ii + ic).Font.Name = detay(aranan(ia, ib), ic, 4)
                            Sayfa18.Cells(i + ib, ii + ic).Font.Size = detay(aranan(ia, ib), ic, 5)
                            Sayfa18.Cells(i + ib, ii + ic).Interior.Color = detay(aranan(ia, ib), ic, 6)
devam::
                        Next ic
                    Next ib
                End If
            Next ia
        Next ii
    Next i
   
    For i = 8 To 40 Step 7
        Sayfa18.Range("B" & i & ":F" & i + 4).Borders.LineStyle = 1
        Sayfa18.Range("h" & i & ":l" & i + 4).Borders.LineStyle = 1
        Sayfa18.Range("n" & i & ":r" & i + 4).Borders.LineStyle = 1
        Sayfa18.Range("t" & i & ":x" & i + 4).Borders.LineStyle = 1
    Next i
   
    Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
   
  
End Sub
Merhabalar;
Yukarıdaki kod içinde hücre içi yazı karakteri, rengi gibi detaylar var, ancak bunlara ilave olarak kodda belirtilen hücrelere yatay ve dikey ortalama eklemek istiyorum.
Yardımcı olabilir misiniz?
Saygılarımla.
 
Muzaffer Ali

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,743
Excel Vers. ve Dili
2021 Türkçe
Merhaba.
Şu iki satır ile yapabilirsiniz.

Kod: 
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
Siz hangi satırları yapmak istiyorsanız onlara ilave edin.

Örnek:
Kod: 
detay(deger, ib, 1) = Sayfa17.Cells(i + ia, ii + ib + 1).HorizontalAlignment = xlCenter
detay(deger, ib, 1) = Sayfa17.Cells(i + ia, ii + ib + 1).VerticalAlignment = xlBottom
 
P

pasha22

Katılım
27 Ocak 2012
Mesajlar
78
Excel Vers. ve Dili
2016 Türkçe
Altın Üyelik Bitiş Tarihi
27.05.2022
Bu şekilde uyguladım ama olmadı
 
Muzaffer Ali

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,743
Excel Vers. ve Dili
2021 Türkçe
Kodlarınızı düzenledim.
Eğer olmuyorsa dosyanızı ekleyin üzerinde bakalım.

Kod: 
Sub yeni2()

    Dim veri(120), detay(120, 5, 6), aranan(24, 5) As Variant

    deger = 0
    satir = 0
  
    Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
  
    For i = 8 To 42 Step 7
        Sayfa18.Range("B" & i & ":X" & i + 4).Clear
    Next i

    For i = 3 To 42 Step 7
        For ii = 1 To 24 Step 6
            For ia = 0 To 4 ' kişi
                veri(deger) = Sayfa17.Cells(i + ia, ii)
                For ib = 0 To 4 ' sütun değerleri
                    detay(deger, ib, 0) = Sayfa17.Cells(i + ia, ii + ib + 1)  'isim alındı
                    detay(deger, ib, 1) = Sayfa17.Cells(i + ia, ii + ib + 1).Font.Bold ' yazı kalın mı
                    detay(deger, ib, 2) = Sayfa17.Cells(i + ia, ii + ib + 1).Font.Italic ' yazı italik mi
                    detay(deger, ib, 3) = Sayfa17.Cells(i + ia, ii + ib + 1).Font.Color ' yazı rengi
                    detay(deger, ib, 4) = Sayfa17.Cells(i + ia, ii + ib + 1).Font.Name ' yazı ailesi
                    detay(deger, ib, 5) = Sayfa17.Cells(i + ia, ii + ib + 1).Font.Size  ' yazı boyutu
                    detay(deger, ib, 6) = Sayfa17.Cells(i + ia, ii + ib + 1).Interior.Color ' arkaplan rengi
                    detay(deger, ib, 1) = Sayfa17.Cells(i + ia, ii + ib + 1).HorizontalAlignment = xlCenter
                    detay(deger, ib, 1) = Sayfa17.Cells(i + ia, ii + ib + 1).VerticalAlignment = xlBottom

             
                Next ib
                deger = deger + 1
            Next ia
        Next ii
    Next i
  
    For i = 2 To Sayfa14.Cells(Rows.Count, 1).End(3).Row
        If CDate(Sayfa14.Cells(i, 1)) = CDate(Sayfa18.Cells(1, "t")) Then
            satir = i
            Exit For
        End If
    Next i
  
  
    If satir = "" Then

        Exit Sub
    End If
  
    deger = 0
    For i = 2 To 100 Step 5
        aranan(deger, 0) = Sayfa14.Cells(1, i)
        For ii = 0 To 4
            For ia = 0 To 120
                If CStr(Sayfa14.Cells(satir, i + ii)) = CStr(veri(ia)) Then
                    aranan(deger, ii + 1) = ia
                    ia = 120
                End If
            Next ia
        Next ii
        deger = deger + 1
    Next i
  
    For i = 7 To 40 Step 7
        For ii = 2 To 24 Step 6
            For ia = 0 To 24
                If CStr(Sayfa18.Cells(i, ii)) = CStr(aranan(ia, 0)) Then
                    For ib = 1 To 5 ' bulunan alanın alt alta isimleri getirme
                        For ic = 0 To 4 ' bulunan alanın sütunları arasında gezinti
                            If IsEmpty(aranan(ia, ib)) Then GoTo devam
                            Sayfa18.Cells(i + ib, ii + ic) = detay(aranan(ia, ib), ic, 0)
                            Sayfa18.Cells(i + ib, ii + ic).Font.Bold = detay(aranan(ia, ib), ic, 1)
                            Sayfa18.Cells(i + ib, ii + ic).Font.Italic = detay(aranan(ia, ib), ic, 2)
                            Sayfa18.Cells(i + ib, ii + ic).Font.Color = detay(aranan(ia, ib), ic, 3)
                            Sayfa18.Cells(i + ib, ii + ic).Font.Name = detay(aranan(ia, ib), ic, 4)
                            Sayfa18.Cells(i + ib, ii + ic).Font.Size = detay(aranan(ia, ib), ic, 5)
                            Sayfa18.Cells(i + ib, ii + ic).Interior.Color = detay(aranan(ia, ib), ic, 6)
                            Sayfa18.Cells(i + ib, ii + ic).Interior.Color = Sayfa17.Cells(i + ia, ii + ib + 1).HorizontalAlignment = xlCenter
                            Sayfa18.Cells(i + ib, ii + ic).Interior.Color = Sayfa17.Cells(i + ia, ii + ib + 1).VerticalAlignment = xlBottom

devam::
                        Next ic
                    Next ib
                End If
            Next ia
        Next ii
    Next i
  
    For i = 8 To 40 Step 7
        Sayfa18.Range("B" & i & ":F" & i + 4).Borders.LineStyle = 1
        Sayfa18.Range("h" & i & ":l" & i + 4).Borders.LineStyle = 1
        Sayfa18.Range("n" & i & ":r" & i + 4).Borders.LineStyle = 1
        Sayfa18.Range("t" & i & ":x" & i + 4).Borders.LineStyle = 1
    Next i
  
    Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
  
 
End Sub
 
P

pasha22

Katılım
27 Ocak 2012
Mesajlar
78
Excel Vers. ve Dili
2016 Türkçe
Altın Üyelik Bitiş Tarihi
27.05.2022
Sayın @dalgalikur, yardımınız için teşekkür ederim.
Dosya ektedir.
Saygılarımla.
 

Ekli dosyalar

P

pasha22

Katılım
27 Ocak 2012
Mesajlar
78
Excel Vers. ve Dili
2016 Türkçe
Altın Üyelik Bitiş Tarihi
27.05.2022
Sanırım olmuyor.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,520
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Kodlarınızın sonuna aşağıdaki bloğu ekleyip deneyiniz.

Hücre aralığını dilediğiniz gibi değiştirebilirsiniz.

Kod: 
    With Sayfa18.Range("B3:X40")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .EntireColumn.AutoFit
    End With
 
P

pasha22

Katılım
27 Ocak 2012
Mesajlar
78
Excel Vers. ve Dili
2016 Türkçe
Altın Üyelik Bitiş Tarihi
27.05.2022
Sayın @Korhan Ayhan hocam, istediğim gibi ayarladım, çok teşekkür ederim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst