Koda "Ek" Yardım Talebi

[ALTINYAYLA]

Selam Arkadaşlar, aşağıdaki koda göre Altın Kur, Dolar Kur ve Euro Kur Sayfalarını kullanıyorum. Bunların yanısıra "Gümüş Kur" sayfası da oluşturup fiyatları takip etmek istiyorum. Bu koda gerekli düzenlemeyi yapmak için yeteri kadar kod bilgim bulunmadığından ilgili koda düzenlemeyi yaparsanız sevinirim...

----------------------------------------------------------

Private Sub Worksheet_Calculate()
Dim S1, S2, S3 As Worksheet, Bul1, Bul2, Bul3 As Range, Sat1, Sat2, Sat3 As Long
Dim Mak1, Mak2, Mak3 As Double, Min1, Min2, Min3 As Double

Set wf = WorksheetFunction: Set S1 = Sheets("Dolar Kur")
Set S2 = Sheets("Euro Kur"): Set S3 = Sheets("Altın Kur")

Set Bul1 = S1.Range("A:A").Find(Date)
Set Bul2 = S2.Range("A:A").Find(Date)
Set Bul3 = S3.Range("A:A").Find(Date)

If Not Bul1 Is Nothing Then
Min1 = wf.Min(S1.Range("B" & Bul1.Row, "C" & Bul1.Row), [C2])
Mak1 = wf.Max(S1.Range("B" & Bul1.Row, "C" & Bul1.Row), [C2])
Bul1.Offset(, 1) = Min1: Bul1.Offset(, 2) = Mak1
Else
Sat1 = S1.Cells(Rows.Count, 1).End(3).Row + 1
S1.Cells(Sat1, 1) = Date: S1.Cells(Sat1, 2) = [C2]
End If
If Not Bul2 Is Nothing Then
Min2 = wf.Min(S2.Range("B" & Bul2.Row, "C" & Bul2.Row), [C3])
Mak2 = wf.Max(S2.Range("B" & Bul2.Row, "C" & Bul2.Row), [C3])
Bul2.Offset(, 1) = Min2: Bul2.Offset(, 2) = Mak2
Else
Sat2 = S2.Cells(Rows.Count, 1).End(3).Row + 1
S2.Cells(Sat2, 1) = Date: S2.Cells(Sat2, 2) = [C3]
End If
If Not Bul3 Is Nothing Then
Min3 = wf.Min(S3.Range("B" & Bul3.Row, "C" & Bul3.Row), [C4])
Mak3 = wf.Max(S3.Range("B" & Bul3.Row, "C" & Bul3.Row), [C4])
Bul3.Offset(, 1) = Min3: Bul3.Offset(, 2) = Mak3
Else
Sat3 = S3.Cells(Rows.Count, 1).End(3).Row + 1
S3.Cells(Sat3, 1) = Date: S3.Cells(Sat3, 2) = [C4]
End If
End Sub

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Private Sub Worksheet_Calculate()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, S4 As Worksheet, WF As WorksheetFunction
    Dim Bul1 As Range, Bul2 As Range, Bul3 As Range, Bul4 As Range
    Dim Sat1 As Long, Sat2 As Long, Sat3 As Long, Sat4 As Long
    Dim Mak1 As Double, Mak2 As Double, Mak3 As Double, Mak4 As Double
    Dim Min1 As Double, Min2 As Double, Min3 As Double, Min4 As Double
    
    Set WF = WorksheetFunction
    Set S1 = Sheets("Dolar Kur")
    Set S2 = Sheets("Euro Kur")
    Set S3 = Sheets("Altın Kur")
    Set S4 = Sheets("Gümüş Kur")
    
    Set Bul1 = S1.Range("A:A").Find(Date)
    Set Bul2 = S2.Range("A:A").Find(Date)
    Set Bul3 = S3.Range("A:A").Find(Date)
    Set Bul4 = S3.Range("A:A").Find(Date)
    
    If Not Bul1 Is Nothing Then
        Min1 = WF.Min(S1.Range("B" & Bul1.Row, "C" & Bul1.Row), [C2])
        Mak1 = WF.Max(S1.Range("B" & Bul1.Row, "C" & Bul1.Row), [C2])
        Bul1.Offset(, 1) = Min1: Bul1.Offset(, 2) = Mak1
    Else
        Sat1 = S1.Cells(Rows.Count, 1).End(3).Row + 1
        S1.Cells(Sat1, 1) = Date: S1.Cells(Sat1, 2) = [C2]
    End If
    
    If Not Bul2 Is Nothing Then
        Min2 = WF.Min(S2.Range("B" & Bul2.Row, "C" & Bul2.Row), [C3])
        Mak2 = WF.Max(S2.Range("B" & Bul2.Row, "C" & Bul2.Row), [C3])
        Bul2.Offset(, 1) = Min2: Bul2.Offset(, 2) = Mak2
    Else
        Sat2 = S2.Cells(Rows.Count, 1).End(3).Row + 1
        S2.Cells(Sat2, 1) = Date: S2.Cells(Sat2, 2) = [C3]
    End If
    
    If Not Bul3 Is Nothing Then
        Min3 = WF.Min(S3.Range("B" & Bul3.Row, "C" & Bul3.Row), [C4])
        Mak3 = WF.Max(S3.Range("B" & Bul3.Row, "C" & Bul3.Row), [C4])
        Bul3.Offset(, 1) = Min3: Bul3.Offset(, 2) = Mak3
    Else
        Sat3 = S3.Cells(Rows.Count, 1).End(3).Row + 1
        S3.Cells(Sat3, 1) = Date: S3.Cells(Sat3, 2) = [C4]
    End If

    If Not Bul4 Is Nothing Then
        Min = WF.Min(S4.Range("B" & Bul4.Row, "C" & Bul4.Row), [C4])
        Mak4 = WF.Max(S4.Range("B" & Bul4.Row, "C" & Bul4.Row), [C4])
        Bul4.Offset(, 1) = Min4: Bul4.Offset(, 2) = Mak4
    Else
        Sat4 = S4.Cells(Rows.Count, 1).End(3).Row + 1
        S4.Cells(Sat4, 1) = Date: S4.Cells(Sat4, 2) = [C4]
    End If

    Set WF = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    Set S4 = Nothing
    
    Set Bul1 = Nothing
    Set Bul2 = Nothing
    Set Bul3 = Nothing
    Set Bul4 = Nothing
End Sub

 

[ALTINYAYLA]

Hocam Gümüş Kur İsimli bir sayfa daha açmam gerekiyor değil mi?

 

[Korhan Ayhan]

Evet..

 

[ALTINYAYLA]

Teşekkür ederim sayın hocam