Mevcut ve Yeni Satışların Aylara Göre Tespiti

[a long time ago]

Merhabalar,

İki sayfadan oluşan excel tablomda 1. sayfada satış durumuna ait 3 sütundan oluşan bir tablo yer alıyor. 2. sayfada ise bu satışlara ait temel bilgiler aylara göre sıralanmış bir şekilde mevcut.

Örnekte de yer aldığı şekilde Nisan ayına ait mevcut kayıtların 1. sayfaya ayrı ayrı satırlara aktarılmasını (ilgili kodun, ilgili satışın "Nisan" ayına ait olduğunu anlaması") ve Nisan ayına ait yeni bir kayıt girildiği zaman bunu da tespit edip 1. sayfada yeni bir satıra kaydedilmesini amaçlıyorum. Benim aklıma döngüler geldi ama işin içinden çıkamadım.

Ayrıca son olarak satışa konu olan yeni bir şirket tespit edildiği zaman (örneğin e şirketi) bu şirket isminin 1. sayfada kalın harflerle gösterimini de yapmak istiyorum.

İş için kullanmak istediğim bu çalışmada yardımcı olabilirseniz memnun olurum.. Şimdiden Teşekkürler

 

[hamitcan]

Sayfa1'in kod kısmına ekleyin.

Private Sub Worksheet_Activate()
    Columns(1).Font.Color = xlblack
    Sayfa3.PivotTables(1).PivotCache.Refresh
    For i = 5 To [a65536].End(3).Row - 1
        k = 0
        Arr = Array("a", "b", "c", "d", "e")
        For j = 0 To UBound(Arr)
            If Arr(j) <> Cells(i, 1) Then k = k + 1
        Next
10
        If k = 5 Then Cells(i, 1).Font.Color = vbRed
    Next
End Sub

 

[a long time ago]

Sayfa1'in kod kısmına ekleyin.

Private Sub Worksheet_Activate()
    Columns(1).Font.Color = xlblack
    Sayfa3.PivotTables(1).PivotCache.Refresh
    For i = 5 To [a65536].End(3).Row - 1
        k = 0
        Arr = Array("a", "b", "c", "d", "e")
        For j = 0 To UBound(Arr)
            If Arr(j) <> Cells(i, 1) Then k = k + 1
        Next
10
        If k = 5 Then Cells(i, 1).Font.Color = vbRed
    Next
End Sub

Hamitcan;

Yardımın için teşekkürler. Fakat senin yüklemiş olduğun dosyayı açıp Sheet2'ye geçtiğim zaman Run-Time error "1004" hatası veriyor. Ayrıca pivot tablosunda değilde Sheet1'de mevcut olan tablo üzerinde bu işlemi yapmamız mümkün olabilir mi? Tekrar teşekkürler.

 

[hamitcan]

Sub NN()
Sheets("Sheet1").[a:a].Font.Color = vbBlack
Ay = "nisan"
b = WorksheetFunction.Match(Ay, Sheets("Sheet2").[a:a], 0)
s = WorksheetFunction.Match(Ay, Sheets("Sheet2").[a:a], 1)
k = 3
For i = b To s
k = k + 1
Sheets("Sheet1").Cells(k, 1) = Sheets("Sheet2").Cells(i, 2)
Sheets("Sheet1").Cells(k, 2) = Sheets("Sheet2").Cells(i, 3)
Sheets("Sheet1").Cells(k, 3) = Sheets("Sheet2").Cells(i, 4)
Next
    For i = 4 To Sheets("Sheet1").[a65536].End(3).Row
        c = 0
        Arr = Array("a", "b", "c", "d", "e")
        For j = 0 To UBound(Arr)
            If Arr(j) <> Sheets("Sheet1").Cells(i, 1) Then c = c + 1
        Next
10
        If c = 5 Then Sheets("Sheet1").Cells(i, 1).Font.Color = vbRed
    Next
End Sub

 

[a long time ago]

Sub NN()
Sheets("Sheet1").[a:a].Font.Color = vbBlack
Ay = "nisan"
b = WorksheetFunction.Match(Ay, Sheets("Sheet2").[a:a], 0)
s = WorksheetFunction.Match(Ay, Sheets("Sheet2").[a:a], 1)
k = 3
For i = b To s
k = k + 1
Sheets("Sheet1").Cells(k, 1) = Sheets("Sheet2").Cells(i, 2)
Sheets("Sheet1").Cells(k, 2) = Sheets("Sheet2").Cells(i, 3)
Sheets("Sheet1").Cells(k, 3) = Sheets("Sheet2").Cells(i, 4)
Next
    For i = 4 To Sheets("Sheet1").[a65536].End(3).Row
        c = 0
        Arr = Array("a", "b", "c", "d", "e")
        For j = 0 To UBound(Arr)
            If Arr(j) <> Sheets("Sheet1").Cells(i, 1) Then c = c + 1
        Next
10
        If c = 5 Then Sheets("Sheet1").Cells(i, 1).Font.Color = vbRed
    Next
End Sub

Cevap için çok teşekkür ederim. 1. sayfada kodu denedim hiç bir sorun gözükmedi ki yeni kayıt sayısı 2'den fazla oluncaya dek. 2'den daha fazla kayıt girilmesi durumunda "Takiptekiler" başlığının altındaki değer de alınıyor ancak alınmaması gerekli. Bunun için ne yapılabilir?

 

[hamitcan]

Böyle deneyin.

Sub NN()
Sheets("Sheet1").[a:a].Font.Color = vbBlack
Sheets("Sheet1").[a4:c1000].ClearContents
Ay = "nisan"
b = WorksheetFunction.Match(Ay, Sheets("Sheet2").[a:a], 0)
s = WorksheetFunction.Match(Ay, Sheets("Sheet2").[a:a], 1)
k = 3
For i = b To s
k = k + 1
Sheets("Sheet1").Cells(k, 1) = Sheets("Sheet2").Cells(i, 2)
Sheets("Sheet1").Cells(k, 2) = Sheets("Sheet2").Cells(i, 3)
Sheets("Sheet1").Cells(k, 3) = Sheets("Sheet2").Cells(i, 4)
Next
s = WorksheetFunction.Match("takiptekiler", Sheets("Sheet2").[a:a], 0)
    For i = 4 To s
        c = 0
        Arr = Array("a", "b", "c", "d", "e")
        For j = 0 To UBound(Arr)
            If Arr(j) <> Sheets("Sheet1").Cells(i, 1) Then c = c + 1
        Next
10
        If c = 5 Then Sheets("Sheet1").Cells(i, 1).Font.Color = vbRed
    Next
End Sub

 

[a long time ago]

Çok teşekkürler Hamitcan. sorun çözüldü.