• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

E

EKREM1661

Katılım
10 Kasım 2006
Mesajlar
1,288
Excel Vers. ve Dili
Excel-2016
Saygıdeğer hocam, ekli dosyada görsel olarak belirttim.. OCAK sayfası P6:P130 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 ?
 

Ekli dosyalar

Merhaba.

Ocak adlı sayfanın kod sayfasındaki kodları silin yerine aşağıdakileri kopyalayın.
Kod: 
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
 
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..
 
Merhaba;
makro dener misiniz..
Kod: 
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
 
Teşekkürler. İyi Forumlar.
 
İkinci sorunuz için daha kısa ve hızlı bir kod yazılabilir.

Kod: 
Sub Kopyala()
    Sheets("Sayfa1").Range("F6:F130").Value = Sheets("ARALIK").Range("F6:F130").Value
End Sub
 
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..
 
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.
 

Ekli dosyalar

Ö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..
 

Ekli dosyalar

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

Ekli dosyalar

Hocam çalıştı da, yalnız formülleri metne çeviriyor, yani sıfır olarak aktarıyor. Neden olabilir ?
 
Eğer G ve O sütunlarından bahsediyorsanız.
Sayfa1'in kod sayfasındaki kodları silin yerine aşağıdakini kopyalayın.
Kod: 
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
 
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..
 
Denet misiniz?

Kod: 
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
 
Muzaffer bey, her yönüyle kontrolünü yaptım, kusursuz olmuş, bu iyilığini unutmayacağım. Esenlikler ve hayırlı ömürler dilerim..
 
Teşekkür ederim. Bilmukabele.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst