Sıra numarasını girince, karşılık verileri getirme..

[EKREM1661]

Saygıdeğer hocam, ekli dosyada görsel olarak belirttim.. OCAK sayfası P6130 aralığına, Sayfa1 deki "B6:B130" sıra numaralarını girince;
Sayfa1 "H ,I ,J" sütunlardaki karşılıklarını, OCAK sayfası "S, T, U" sütun karşılıklarına getiriyor..
Burdaki sorun; rakamı silince, getirilen verileri hemen kaldıramıyor, tüm sayıları sayarak bekletiyor. Buna bir çözüm bula bilir miyiz ?

 

[Muzaffer Ali]

Merhaba.

Ocak adlı sayfanın kod sayfasındaki kodları silin yerine aşağıdakileri kopyalayın.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Bul As Range
    If Not Intersect(Target, Range("P:P")) Is Nothing Then
        With Worksheets("Sayfa1")
            Set Bul = .Range("B:B").Find(what:=Target.Text, lookat:=xlWhole)
            If Bul Is Nothing Then
                Target.Offset(0, 3).Value = "Bulunamadı."
            Else
                Target.Offset(0, 3).Value = .Cells(Bul.Row, "H")
                Target.Offset(0, 4).Value = .Cells(Bul.Row, "I")
                Target.Offset(0, 5).Value = .Cells(Bul.Row, "J")
            End If
        End With
    End If
End Sub

 

[EKREM1661]

Hocam, çok çok teşekkür ederim ve ziyadesiyle makbule geçti.. Bir de, ARALIK sayfası F6:F130 aralığını Sayfa1 F6:F130 aralığına getirmede hata alıyorum. Sizin için kolay olacak bu makroyu da belirtirseniz başka bir sorunum kalmıyor..
Hoşça kalınız ve hayırlı ramazanlar diliyorum..

 

[osman06turgut]

Merhaba;
makro dener misiniz..

Sub KopyalaAralik()
Dim wsKaynak As Worksheet
Dim wsHedef As Worksheet

Set wsKaynak = ThisWorkbook.Sheets("ARALIK")
Set wsHedef = ThisWorkbook.Sheets("Sayfa1")

wsKaynak.Range("C6:F130").Copy
wsHedef.Range("C6").PasteSpecial Paste:=xlPasteValues

Application.CutCopyMode = False

MsgBox "Veriler başarıyla kopyalandı!", vbInformation, "İşlem Tamamlandı"
End Sub

 

[EKREM1661]

Osman bey, çok teşekkürler.. Halledilmiş oldu.. Muzaffer bey'in de senin de ilgi/alakanıza minnettarım.. Hoşça kalınız..

 

[osman06turgut]

Teşekkürler. İyi Forumlar.

 

[Muzaffer Ali]

İkinci sorunuz için daha kısa ve hızlı bir kod yazılabilir.

Sub Kopyala()
    Sheets("Sayfa1").Range("F6:F130").Value = Sheets("ARALIK").Range("F6:F130").Value
End Sub

 

[EKREM1661]

Teşekkürler Muzaffer bey, dediğiniz gibi tek satırla daha hızlı çözüm..

 

[EKREM1661]

Muzaffer hocam, düşündüm de; yukarıdaki dosyada;
Sayfa1 deki verileri, formüllerle OCAK, ŞUBAT, MART.... diye devam eden12 sayfaya aktarıyorum.
Ancak Sayfa1 de bazen bilmeyenlern (satır sil ekle gibi) işlemlerinde başvuru formüllerini bozuyor..
Bunu makro ile aktarsak..

Sayfa1 de (B, C. D. E) sütunların B6:B130 aralığı, diğer ay sayfalarına aktarımı..
Başvuru adresleri de hep aynıdır.. B6:E130 aralığı..
Yani;
(Sıra No, Cinsi, TCO No. Plaka No) 6.ncı satırdan itibaren, ay sayfalarına 6.ncı satırdan itibaren aktaran makro..

 

[Muzaffer Ali]

1- 2 numaralı mesajdaki kodu BuÇalışmaKitabı adlı kod sayfasına uygun şekilde değiştirdim. P sütununa bir şey yazdığınız sayfanın adı ay isimlerinden biri ise o sayfada kod otomatik çalışır. Yani kodu her sayfaya tek tek yazmaya gerek yok.
2- 9 numaralı mesajdaki isteğinizi gerçekleştirdim. Sayfa1 de bulunan "Aylara Aktar" butonuna tıkladığınızda çalışacaktır.
3- Bunu istememiştiniz ama G ve O sütunlarında bulunan formülleri de "Aylara Aktar" butonuna tıkladığınızda çalışacak şekilde düzenledim.

 

[EKREM1661]

Öncelikle teşekkür ederim Muzaffer bey, bir sorun oluşturdu. Çalıştırıldığında (ActiveSheet.Name = Syf) satırında takılıyor ve makroyu tamamlayamıyor. Gelen ileti "Bu ad zaten alınmış, farklı bir tane deneyin" şeklinde.. Ayrıca her çalıştırıldığında Sayfa2, Sayfa3.... diye ardışık boş sayfalar üretiyor.
Dosyanın aslını eklersem daha net anlaşılır..

 

[Muzaffer Ali]

Silmem gereken birkaç satırı silmeden dosyayı eklemişim.
Düzelttim yeniden deneyin.

 

[EKREM1661]

Hocam çalıştı da, yalnız formülleri metne çeviriyor, yani sıfır olarak aktarıyor. Neden olabilir ?

 

[Muzaffer Ali]

Eğer G ve O sütunlarından bahsediyorsanız.
Sayfa1'in kod sayfasındaki kodları silin yerine aşağıdakini kopyalayın.

Option Explicit

Private Sub btnAylaraAktar_Click()
    Dim Sayfalar As Variant
    Dim Syf As Variant
    Dim SatirSay As Integer
    Sayfalar = Array("OCAK", "ŞUBAT", "MART", "NİSAN", "MAYIS", "HAZİRAN", "TEMMUZ", "AĞUSTOS", "EYLÜL", "EKİM", "KASIM", "ARALIK")
    SatirSay = Cells(Rows.Count, "C").End(xlUp).Row
    Application.EnableEvents = False
    For Each Syf In Sayfalar
        Sheets(Syf).Range("B6:E" & SatirSay).Value = Sheets("Sayfa1").Range("B6:E" & SatirSay).Value
        Sheets(Syf).Range("G6:G" & SatirSay).FormulaLocal = "=EĞER(F6>Sayfa1!F6;" & Syf & "!F6-Sayfa1!F6;0)"
        Sheets(Syf).Range("O6:O" & SatirSay).FormulaLocal = "=TOPLA(J6:N6)"
    Next
    Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("C6:C" & Rows.coun)) Is Nothing Then
        If Target <> "" Then
            Cells(Target.Row, "B") = WorksheetFunction.Max(Range("B5:B" & Target.Row - 1)) + 1
        Else
            Cells(Target.Row, "B") = ""
        End If
    End If
End Sub

 

[EKREM1661]

Hocam her şey çok güzel elinize sağlık.. Ancak sanırım formüllerde gözden kaçan bir durum var..
Şöyleki; her sayfanın "G" sütunundaki formüllerin başvurusu farklı..
Örneğin; Şubat ayı km.sini çıkartmak için, malum bir önceki (ocak) ayın toplam km.sini düşmesi lazım.

Her ayın km hesabı bir önceki aya bağlı,
OCAK ayı'nın ki ise Sayfa1 "F" sütununa.. (Burdaki "F" sütunu rakamlarını da bir önceki senenin Aralık ayından almıştık)

Herhalde her sayfa için ayrı ayrı formül mü oluşturacağız..

 

[Muzaffer Ali]

Denet misiniz?

Option Explicit

Private Sub btnAylaraAktar_Click()
    Dim Sayfalar As Variant
    Dim Syf As Variant
    Dim SatirSay As Integer
    Dim FSayfa As String
    
    Sayfalar = Array("OCAK", "ŞUBAT", "MART", "NİSAN", "MAYIS", "HAZİRAN", "TEMMUZ", "AĞUSTOS", "EYLÜL", "EKİM", "KASIM", "ARALIK")
    SatirSay = Cells(Rows.Count, "C").End(xlUp).Row
    Application.EnableEvents = False
    For Each Syf In Sayfalar
        If FSayfa = "" Then FSayfa = "Sayfa1"
        Sheets(Syf).Range("B6:E" & SatirSay).Value = Sheets("Sayfa1").Range("B6:E" & SatirSay).Value
        Sheets(Syf).Range("G6:G" & SatirSay).FormulaLocal = "=EĞER(F6>" & FSayfa & "!F6;" & Syf & "!F6-" & FSayfa & "!F6;0)"
        Sheets(Syf).Range("O6:O" & SatirSay).FormulaLocal = "=TOPLA(J6:N6)"
        FSayfa = Syf
    Next
    Application.EnableEvents = True
    MsgBox "Aktarma tamamlandı.", vbInformation
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("C6:C" & Rows.coun)) Is Nothing Then
        If Target <> "" Then
            Cells(Target.Row, "B") = WorksheetFunction.Max(Range("B5:B" & Target.Row - 1)) + 1
        Else
            Cells(Target.Row, "B") = ""
        End If
    End If
End Sub

 

[EKREM1661]

Muzaffer bey, her yönüyle kontrolünü yaptım, kusursuz olmuş, bu iyilığini unutmayacağım. Esenlikler ve hayırlı ömürler dilerim..

 

[Muzaffer Ali]

Teşekkür ederim. Bilmukabele.