Hücrelerden veri alma bir kez çalışıyor. Sonra çalışmıyor.

[Kullanıcı Silindi 605]

Excel dosyasında,
Sayfa1 de bulunan A1 ve A2 hücrelerine Sayfa2 deki B1 ve B2 de verileri almak istiyorum.

Sayfa1 A1 hücresi boşsa veya Sayfa B2 hücresindeki değere eşitse veya Sayfa B2 hücresinden Küçükse veya Sayfa B2 hücresinden Büyükse;
Sayfa B2 hücresindeki değeri Sayfa1 deki A1 hücresine yazsın.
Aşağıdaki kodla denemelerde dosya ilk açıldığında şablon çalışıyor. Dosyayı farklı kayıt ediyorum.
Fakat şablon dosyasını tekrar açtığımda hücreler değişmiyor. Kod çalışmıyor.

Şablon dosyasını açtıktan ve Sayfa1 deki diğer hücrelere veri girip farklı kaydetikten sonra, Şablon dosyasındaki hücreleri nasıl boş bırakabilirim.


Sayfa2 den alınacak hücre bilgileri.

Kod: Tümünü seç

Private Sub Workbook_Open()
If Sheets(1).Range("A1") = "" Then
Sheets(2).Range("B1") = Sheets(2).Range("B1") + 1
Sheets(1).Range("A1") = Sheets(2).Range("B1")
Sheets(1).Range("A3") = Sheets(2).Range("B3")
End If
If Sheets(1).Range("A1") = Sheets(2).Range("B1") Then
Sheets(2).Range("B1") = Sheets(2).Range("B1") + 1
Sheets(1).Range("A1") = Sheets(2).Range("B1")
Sheets(1).Range("A3") = Sheets(2).Range("B3")
End If
If Sheets(1).Range("A1") < Sheets(2).Range("B1") Then
Sheets(2).Range("B1") = Sheets(2).Range("B1") + 1
Sheets(1).Range("A1") = Sheets(2).Range("B1")
Sheets(1).Range("A3") = Sheets(2).Range("B3")
End If
If Sheets(1).Range("A1") > Sheets(2).Range("B1") Then
Sheets(2).Range("B1") = Sheets(2).Range("B1") + 1
Sheets(1).Range("A1") = Sheets(2).Range("B1")
Sheets(1).Range("A3") = Sheets(2).Range("B3")
End If
End Sub

Bu şekilde de denedim aynı. Kod çalışmıyor.

Kod: Tümünü seç

Private Sub Workbook_Open()
If Sheets(1).Range("A1") = "" Then
sakla = ActiveWorkbook.Name
Sheets(2).Range("B1") = Sheets(2).Range("B1") + 1
Sheets(1).Range("A1") = Sheets(2).Range("B1")
Sheets(1).Range("A3") = Sheets(2).Range("B3")
Workbooks(sakla).Activate
End If

[SNNAY]

Bu kodu, ThisWorkbook modülüne yerleştirmeniz gerekiyor. Bu sayede dosya her açıldığında Workbook_Open olayı tetiklenir ve CheckAndCopyValues alt programı çalışır.

Kod: Tümünü seç

Private Sub Workbook_Open()
    Call CheckAndCopyValues
End Sub

Sub CheckAndCopyValues()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim valueB2 As Variant

    Set ws1 = ThisWorkbook.Sheets("Sayfa1")
    Set ws2 = ThisWorkbook.Sheets("Sayfa2")

    valueB2 = ws2.Range("B2").Value

    ' A1 hücresi için kontrol ve kopyalama
    If IsEmpty(ws1.Range("A1")) Or ws1.Range("A1").Value = valueB2 Or ws1.Range("A1").Value < valueB2 Or ws1.Range("A1").Value > valueB2 Then
        ws1.Range("A1").Value = valueB2
    End If

    ' A2 hücresi için kontrol ve kopyalama
    If IsEmpty(ws1.Range("A2")) Or ws1.Range("A2").Value = valueB2 Or ws1.Range("A2").Value < valueB2 Or ws1.Range("A2").Value > valueB2 Then
        ws1.Range("A2").Value = valueB2
    End If
End Sub

Şimdi, şablon dosyasını açtıktan sonra, Sayfa1'deki diğer hücrelere veri girdikten sonra hücreleri boş bırakmak için bir çözüm sunalım. Bu işlemi gerçekleştirmek için bir buton ekleyebiliriz ve bu butona tıklanınca hücreleri boş bırakacak bir makro
Buton Ekleyin:
Excel'de Geliştirici sekmesine gidin.
Ekle > Form Denetimleri > Buton (Komut Düğmesi) seçeneğini seçin.
Butonu Sayfa1'e yerleştirin ve aşağıda ki makroyu atayın.

Kod: Tümünü seç

Sub ClearTemplateCells()
    Dim ws1 As Worksheet
    Set ws1 = ThisWorkbook.Sheets("Sayfa1")

    ' Hücreleri boş bırak
    ws1.Range("A1").ClearContents
    ws1.Range("A2").ClearContents

    ' Gerekirse diğer hücreleri de boş bırakabilirsiniz
    ' ws1.Range("B1").ClearContents
    ' ws1.Range("C1:C10").ClearContents
End Sub

[Kullanıcı Silindi 605]

Sayın SNNAY başta ilgine teşekkürler.

Anladığım kadarı ile;
-İlk kodunuzda ' A1 hücresi için kontrol ve kopyalama" kısmı, Sayfa1 A1 hücresi ile Sayfa2 B2 hücresini karşılaştırıyor.
-Buda "ws1.Range("A1").Value = valueB2" Sayfa1 A1 hücresine Sayfa2 B2 hücresindeki değeri kopyalıyor.

-Yine ilk kodunuzda ' A2 hücresi için kontrol ve kopyalama kısmı Sayfa1 A2 hücresi ile Sayfa1 A2 karşılatırıyor. Yani terslik var gibi veya ben tam anlamadım. Çünkü ws1 sayfa1 ws2 Sayfa 2 diye tanımlanmış.

Kodu denedim fakat çalışmadı.

Benim yapmak istediğim Dosya her açıldığında Sayfa2 B1 hücresinin mevcut değeri +1 artsın, bu artan değeri (Örneğin 1 ise 2 yapsın) Sayfa1 A1 hücresine yazsın. Aynı Sayfa2 B3 hücresindeki değeri (Zaten o tarih METNEÇEVİR(BUGÜN();"gg aa yyyy")) Sayfa1 A1 hücresine yazsın ve Sayfa2 B1 hücresi hep artığı değerde kalacak. Dosyayı farklı kayıt ediyorum. Şablon u tekrar açtığımda açıkladığım tekrar Sayfa2 B1 bir artacak Sayfa1 A1 yazacak şekilde. Farklı kayıt ettiğim dosya artan değerlerle kayıt olacak.

Umarım anlatabildim. Senin kodları, bilgim dahilinde bazı yerlerini düzenleyip denemeye devam edeceğim.

[Kullanıcı Silindi 605]

Bu şekilde denedim. Sayfa1 A1 A2 den biri veya ikisinde değer olmaz ise çalışıyor fakat Sayfa2 B1 değeri artmıyor bundan ötürü aynı değerler (1 se 1 ) geliyor. Denmeye devam edeceğim.

Kod: Tümünü seç

Private Sub Workbook_Open()
    Call CheckAndCopyValues
End Sub

Sub CheckAndCopyValues()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim valueB2 As Variant

    Set ws1 = ThisWorkbook.Sheets("Sayfa1")
    Set ws2 = ThisWorkbook.Sheets("Sayfa2")

    valueB2 = ws2.Range("B2").Value

        ' A1 hücresi için kontrol ve kopyalama
    If IsEmpty(ws1.Range("A1")) Or ws1.Range("A1").Value = valueB1 Or ws1.Range("A1").Value < valueB1 Or ws1.Range("A1").Value > valueB1 Then
        ws2.Range("B1").Value = valueB1 + 1
        ws1.Range("A1").Value = ws2.Range("B1").Value
    End If

    ' A2 hücresi için kontrol ve kopyalama
    If IsEmpty(ws1.Range("A2")) Or ws1.Range("A2").Value = valueB2 Or ws1.Range("A2").Value < valueB2 Or ws1.Range("A2").Value > valueB2 Then
        ws1.Range("A2").Value = valueB2
    End If
End Sub