[Yardım]  Hücreyi yatay ve dikey ortalama

VBA Makrolar ile ilgili sormak istedikleriniz, yapmak istedikleriniz hakkında yardım alabileceğiniz bölümdür.

Hücreyi yatay ve dikey ortalama

İleti#1)  pasha22 » 31 Ekm 2019 11:02

Kod: Tümünü seç
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.

Bu kodları ekledim olmadı.
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

Örnek dosta ektedir, yardımcı olabilir misiniz?
Saygılarımla.
Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
Kullanıcı avatarı
pasha22
Yeni Başlamış
 
Adı Soyadı:Selçuk YILDIRIM
Kayıt: 12 Şub 2012 12:32
Konum: İstanbul
Meslek: serbest
Yaş: 41
İleti: 35
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İstanbul

Cevap: Hücreyi yatay ve dikey ortalama

İleti#2)  romanci05 » 31 Ekm 2019 15:33

Merhaba,

Sorununuza en basit çözüm;

Range("D2").Select ' Siz burda aktif hücreyi seçtirin.
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With

şeklinde with komutuyla istediğinizi yapabilirsiniz.
Kullanıcı avatarı
romanci05
 
Kayıt: 28 Oca 2016 13:12
Meslek: Öğretmen
Yaş: 47
İleti: 7
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İzmir

Cevap: Hücreyi yatay ve dikey ortalama

İleti#3)  romanci05 » 31 Ekm 2019 15:45

Tekrar merhaba,
Aşağıda kırmızı renk ile belirttiğim şekilde uygulayınca sorunsuz çalıştı.

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, 6) = Sayfa17.Cells(i + ia, ii + ib + 1).Interior.Color ' arkaplan rengi
detay(deger, ib, 6) = Sayfa17.Cells(i + ia, ii + ib + 1).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With

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
MsgBox "Tarih bulunmamıştır.", vbInformation, "Yasin BAS"
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

MsgBox "..:: | Bitti | ::..", vbInformation, "Yasin BAS"
End Sub
Kullanıcı avatarı
romanci05
 
Kayıt: 28 Oca 2016 13:12
Meslek: Öğretmen
Yaş: 47
İleti: 7
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İzmir

Cevap: Hücreyi yatay ve dikey ortalama

İleti#4)  pasha22 » 31 Ekm 2019 18:55

Sayın @romanci05;
Yardımınız için teşekkür ederim.
dediğiniz şekilde dosyaya uyguladım ama ekteki hatayı verdi, nerede yanlış yaptım acaba?
Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
Kullanıcı avatarı
pasha22
Yeni Başlamış
 
Adı Soyadı:Selçuk YILDIRIM
Kayıt: 12 Şub 2012 12:32
Konum: İstanbul
Meslek: serbest
Yaş: 41
İleti: 35
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İstanbul

REKLAM
Excel Logo XML Oluşturucu
Logo Object Designer ile Uyarlama

Cevap: Hücreyi yatay ve dikey ortalama

İleti#5)  pasha22 » 01 Kas 2019 14:13

Güncel.
Kullanıcı avatarı
pasha22
Yeni Başlamış
 
Adı Soyadı:Selçuk YILDIRIM
Kayıt: 12 Şub 2012 12:32
Konum: İstanbul
Meslek: serbest
Yaş: 41
İleti: 35
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İstanbul

Cevap: Hücreyi yatay ve dikey ortalama

İleti#6)  ahmetilhan282 » 03 Kas 2019 22:58

hata veren satırı silip deneyin.
Kullanıcı avatarı
ahmetilhan282
Site Dostu
 
Adı Soyadı:Ahmet İLHAN
Kayıt: 15 Oca 2014 00:04
Konum: Adana
Meslek: Güvenlik
Yaş: 29
İleti: 873
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Mersin

REKLAM
ETA - Excel Konsolide Raporlama
ETA Excel Personel Entegre Raporu

Cevap: Hücreyi yatay ve dikey ortalama

İleti#7)  pasha22 » 03 Kas 2019 23:22

Hata veren dosyayı silersem yine hata veriyor.
Kullanıcı avatarı
pasha22
Yeni Başlamış
 
Adı Soyadı:Selçuk YILDIRIM
Kayıt: 12 Şub 2012 12:32
Konum: İstanbul
Meslek: serbest
Yaş: 41
İleti: 35
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İstanbul

Cevap: Hücreyi yatay ve dikey ortalama

İleti#8)  pasha22 » 08 Kas 2019 21:50

Olmuyor galiba.
Kullanıcı avatarı
pasha22
Yeni Başlamış
 
Adı Soyadı:Selçuk YILDIRIM
Kayıt: 12 Şub 2012 12:32
Konum: İstanbul
Meslek: serbest
Yaş: 41
İleti: 35
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İstanbul


Forum Genel Makro Soruları

Online Kullanıcılar

Bu forumu görüntüleyenler: Kayıtlı kullanıcı yok ve 2 misafir

cron
Bumerang - Yazarkafe