• DİKKAT

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

Soru Hücreyi yatay ve dikey ortalama

  • Konbuyu başlatan Konbuyu başlatan pasha22
  • Başlangıç tarihi Başlangıç tarihi
P

pasha22

Katılım
27 Ocak 2012
Mesajlar
78
Excel Vers. ve Dili
2016 Türkçe
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.
 
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
 
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
 
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
 
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.
Geri
Üst