tablodaki her bir satırın içindeki min ve maks rakamları renkli dolgu ile göstermek

[hanoglu]

selamlar,

elimizde değişik ürünler için değişik firmaların verdikleri fiyat teklifleri mevcut. yapmak istediğim aşağıdaki gibi ürün ve firma olarak sayısı her defasında değişen bir tabloda
her bir ürüne ait minimum ve maksimum rakamları bulup, minimum rakamları maviye maksimum rakamları da kırmızıya boyayabilecek olan bir kod yazabilmek.
yardımcı olabilecek arkadaşlarımıza şimdiden teşekkürler..



****** Z firması Y firması V firması U firması .... ....
a ürünü 50 tl*** 40 tl ** 25 tl *** 30 tl ***
b ürünü 150 tl** 100 tl * 140 tl ** 90 tl ***
c ürünü 100 tl** 85 tl ** 95 tl *** 80 tl ***
...
...
...

 

[Necdet]

Merhaba,

Keşke örnek dosya ekleseydiniz.

Aşağıdaki dosyayı inceleyiniz, Koşullu Biçimlendirme ile yapılmıştır. İsterseniz makrolu çözüm de sunabiliriz.

B2:E4 aralığında uygulanmıştır.

En Büyük Değer İçin :

=MAK($B2:$E2)=B2
=MAX($B2:$E2)=B2

En Küçük Değer İçin :

=MİN($B2:$E2)=B2
=MIN($B2:$E2)=B2

 

[hanoglu]

makrolu çözüm

selamlar,

dosyanın kesitini koydum, bu dosya firma ve ürün olarak daha geniş olacak. Tablo boyutunu algılayıp da ona göre deiğimiz işlemi yapabilecek bir koda ihitiyacımız var.

umarım yardımcı olabilirsiniz..

 

[Necdet]

Merhaba,

Dosyanın bir örneğini görmek gerek.

 

[Necdet]

Merhaba,

Kodları inceleyiniz, gerekirse kendinize göre uyarlayınız.

Sub MaxMin()
Dim i As Long
Dim j, SonKolon As Integer
Dim Buyuk, Kucuk As Double
SonKolon = [IV1].End(1).Column
Application.ScreenUpdating = False
Cells.Interior.ColorIndex = xlNone
For i = 2 To [A65536].End(3).Row
    Buyuk = Application.WorksheetFunction.Max(Range(Cells(i, "B"), Cells(i, SonKolon)))
    Kucuk = Application.WorksheetFunction.Min(Range(Cells(i, "B"), Cells(i, SonKolon)))
    For j = 2 To SonKolon
        If Cells(i, j) = Buyuk Then Cells(i, j).Interior.ColorIndex = 5
        If Cells(i, j) = Kucuk Then Cells(i, j).Interior.ColorIndex = 3
    Next j
Next i
Application.ScreenUpdating = True
MsgBox "İşlem tamam"
End Sub

 

[hanoglu]

tablo

merhaba,

yardımlarınız için çok teşekkürler.
koşullu biçimlendirme daha kolay olacak sanırım. Ekte size dosyayı yolluyorum. dosyanın ilk iki sayfası manuel yapılan renklendirme. Son sayfasına sizin formüle ettiğiniz koşullu biçimlendirmeyi uyguladım, fakat aradaki boş hücrelerde de bu biçimlendirmeyi yaptı, ben formül kısmına "eğer hücre boşsa boş bırak, değilse formülü uygula" gibi bir ilave yapmaya çalıştım ama çok fazla parametre oldugunu söyledi program ve olmadı istediğim. Boş kısımlara bu koşulu uygulatmamamız gerekli.

buna nasıl bir çözüm önerirsiniz.

 

[iplikci_80]

aşağıdaki makroda örneğin 1.500,00.-TL'yi yazıyla yazdırmak istediğimizde (Birbinbeşyüz Türklirası) olarak yazıyor. Bunu (Binbeşyüz Türklirası) yazacak şekilde düzeltebilirmiyiz





Function YAZIYLA(Sayi#)
Dim virgul2 As String
Dim cevap As String
Dim yazi As String
Dim Say As String
Dim uclu As String
Dim virgul As Integer
Dim o As Integer
Dim b As Integer
Dim x As Integer
Dim i As Integer
Dim y As Integer
Dim TL As String
Dim KR As String

If Sayi# = 0 Then YYaziyla = "Sıfır": Exit Function

ReDim birler$(10), onlar$(10), basamak$(5)

birler$(0) = "": birler$(1) = "BİR"
birler$(2) = "İKİ": birler$(3) = "ÜÇ"
birler$(4) = "DÖRT": birler$(5) = "BEŞ"
birler$(6) = "ALTI": birler$(7) = "YEDİ"
birler$(8) = "SEKİZ": birler$(9) = "DOKUZ"

onlar$(0) = "": onlar$(1) = "ON"
onlar$(2) = "YİRMİ": onlar$(3) = "OTUZ"
onlar$(4) = "KIRK": onlar$(5) = "ELLİ"
onlar$(6) = "ALTMIŞ": onlar$(7) = "YETMİŞ"
onlar$(8) = "SEKSEN": onlar$(9) = "DOKSAN"

basamak$(1) = "": basamak$(2) = "BİN "
basamak$(3) = "MİLYON ": basamak$(4) = "MİLYAR "
basamak$(5) = "TRİLYON "

virgul2 = ""
cevap = ""

'AŞAĞIDAKİ 2 SATIRDAKİ ÇİFT TIRNAK İÇERİĞİNİ DEĞİŞTİREREK
'VEYA ÇİFT TIRNAĞIN ARASINI SİLEREK "" VEYA "," GİBİ
'İSTEĞİNİZ SONUCUN ÇIKMASINI SAĞLAYABİLİRSİNİZ.
TÜRKLİRASI = " TÜRKLİRASI "
KURUŞ = " KURUŞ "

Say = Str$(Sayi#)
virgul = InStr(1, Say, ".")
If virgul Then

'Aşağadaki satır 26,4 Yirmialtı TÜRKLİRASI, KIRK KURUŞ olarak okutur.
' (Yirmialtı TÜRKLİRASI, DÖRT KURUŞ olarak değil)
'İptal etmek isterseniz başına bir ' tek tırnak işareti koyunuz
If Len(Mid(Say, virgul + 1)) = 1 Then Say = Say + "0"

Say = Right$(Say, Len(Say) - virgul)
GoSub cevir

If cevap = "" Then KURUŞ = ""
virgul2 = cevap + KURUŞ
cevap = ""

Say = Str$(Sayi#)
Say = Left$(Say, virgul - 1)
End If
GoSub cevir
If cevap = "" Then TÜRKLİRASI = ""
YAZIYLA = cevap + TÜRKLİRASI + virgul2
Exit Function

cevir:
x = Len(Say)
Say = String$(3 - (x - Int(x / 3) * 3), 48) + Say
x = Len(Say) / 3
For i = 1 To x
uclu = Mid$(Say, Len(Say) - i * 3 + 1, 3)
y = Val(Mid$(uclu, 1, 1))
o = Val(Mid$(uclu, 2, 1))
b = Val(Mid$(uclu, 3, 1))

yazi = ""
If y <> 0 Then
If y > 1 Then yazi = birler$
yazi = yazi + "YÜZ "
End If

yazi = yazi + onlar$(o) + birler$(b)

If yazi <> "" Then
If LCase(yazi) = "bir" And i = 2 Then yazi = ""
cevap = yazi + basamak$(i) + cevap
End If
Next i
If Sayi# < 0 Then cevap = "-Eksi-" + cevap
Return
End Function

 

[Necdet]

Merhaba,

Gerçek dosya olunca işler değişiyor tabi.

Koşul :

=VE(I8>0;I8=MAK($I8:$L8))
=AND(I8>0;I8=MAX($I8:$L8))

=AND(I8>0;I8=MİN($I8:$L8))
=AND(I8>0;I8=MIN($I8:$L8))

 

[hanoglu]

formülasyon

necdet bey,

elinize sağlık, çok teşekkürler.

hani ben de makrolarla uğraşmak bi şeyler yapabilmek amacındayım ama, görüyorum ki henüz programlama öncesi excel bilgim bile yeterli seviyede değil. ne yapmalı, neleri tavsiye edersiniz ? hangi kitapları incelemeli ?...

teşekkürler tekrar..

 

[Necdet]

Merhaba,

Aşağıdaki linki inceleyebilirsiniz.

http://www.excel.web.tr/f151/