Çözüldü Sayfalar arasında yazılan veriye göre aktarma yapmak VBA

[Faulkner]

Merhaba Arkadaşlar,

Aşağıdaki vba kod da senaryo yu anlatmak isterim.

Excel dosyasında, sayfalar arasında "profil no" ya göre veri çekmek istiyorum.

Ayrıntılı olarakta şu şekilde anlatayım. "Dim kaynakSayfa As Worksheet" sayfasında bulunan "F" Sütunundaki "Profil No" başlığına bakarak, "Dim hedefSayfa As Worksheet" sayfasında X1 hücresine ne yazdıysam ona göre verileri getirmesini istiyorum.

Yardımlarınızı bekliyorum. saygılarımla

DOSYA LİNK:
DENEME.xlsm - 733 KB

EXCEL VBA KOD:

Private Sub CommandButton1_Click()

Range("A1:V999999").ClearContents

Dim kaynakSayfa As Worksheet
Dim hedefSayfa As Worksheet

' Kaynak sayfayı belirtin
Set kaynakSayfa = Sheets("Güncel")

' Hedef sayfayı belirtin
Set hedefSayfa = Sheets("Sayfa1")

' Verileri kopyalayın
kaynakSayfa.Range("A1:w9999").Copy hedefSayfa.Range("A1")

' Belleği temizleyin
Application.CutCopyMode = False

End Sub

 

[Muzaffer Ali]

Merhaba.

Private Sub CommandButton1_Click()
    Dim KaynakSayfa As Worksheet
    Dim Bul As Range
    Dim Say As Long
    Set KaynakSayfa = Sheets("Güncel")
    
    If IsEmpty(Range("X1")) Then
        MsgBox "Lütfen önce aramak istediğiniz 'Profil No' yazınız.", vbExclamation
        Range("X12").Select
        Exit Sub
    Else
        Set Bul = KaynakSayfa.Range("F:F").Find(what:=Range("X1").Text, lookat:=xlWhole)
        If Bul Is Nothing Then
            MsgBox "Aradığınız 'Profil No' bulunamadı.", vbInformation
            Exit Sub
        Else
            Say = Cells(Rows.Count, "A").End(xlUp).Row + 1
            KaynakSayfa.Range("A" & Bul.Row & ":V" & Bul.Row).Copy Cells(Say, "A")
        End If
    End If
End Sub

 

[Faulkner]

merhaba,

"güncel" sayfasında ilk sıradaki veriyi getiriyor. bana tamamını gelmesi lazım. veri pilotundaki mantık gibi olacak.

 

[Muzaffer Ali]

X1 hücresine ne yazdıysam ona göre verileri getirmesini istiyorum.

Dediğiniz için öyle yaptım.
X1'e yazılan profil No Güncel sayfası F sütununda arayıp sadece bulduğu satırı kopyalıyor.

Daha fazla detay verir misiniz?
X1'e yazılan değerin anlamı nedir?
Eğer tüm satırlar gelecekse X1'deki değer neyi ifade ediyor?

 

[Faulkner]

X1 hücresine profil numarası yazdığımda

"Güncel" sekmesinde olan tüm yazdığım profil numarasının verilerinin gelmesini istiyorum.

 

[Muzaffer Ali]

Örnekteki dosyada X1 hücresine "897/B" yazmışsınız.
Bu örneğe göre yukarıda yazdığım kod, "Güncel" sayfasının "F" sütununda sadece bir tane "897/B" olduğu için bir tane Sayfa1'e aktarıyor.

 

[dEdE]

Ben aşağıdaki gibi anladım.
Sayfanın kod bölümüne kopyalayıp dener misiniz?

Private Sub CommandButton1_Click()
    Set s1 = Sheets("Güncel")
    Set s2 = Sheets("Sayfa1")
    Set c = s1.Range("F:F").Find(s2.Range("X1"), , xlValues)
    If Not c Is Nothing And s2.Range("X1") <> "" Then
        adres = c.Address
        s2.Range("A2:V" & s2.Cells(Rows.Count, "A").End(3).Row).ClearContents
        Do
            ss2 = s2.Cells(Rows.Count, "A").End(3).Row + 1
            s1.Range(Cells(c.Row, 1).Address, Cells(c.Row, 20).Address).Copy s2.Range("A" & ss2)
            Set c = s1.Cells.FindNext(c)
        Loop While Not c Is Nothing And c.Address <> adres
        Exit Sub
    End If
    MsgBox s2.Range("X1").Value & " Profil Numarası Kayıtlı değil.", vbCritical, "DİKKAT"
    s2.Range("X1") = ""
End Sub

 

[Faulkner]

Örnekteki dosyada X1 hücresine "897/B" yazmışsınız.
Bu örneğe göre yukarıda yazdığım kod, "Güncel" sayfasının "F" sütununda sadece bir tane "897/B" olduğu için bir tane Sayfa1'e aktarıyor.

Bendeki dosyada 1 sen fazla var. Forumda paylaştığım excel dosyasında silmiştim dosya hafif olsun diye.

 

[Faulkner]

Ben aşağıdaki gibi anladım.
Sayfanın kod bölümüne kopyalayıp dener misiniz?

Private Sub CommandButton1_Click()
    Set s1 = Sheets("Güncel")
    Set s2 = Sheets("Sayfa1")
    Set c = s1.Range("F:F").Find(s2.Range("X1"), , xlValues)
    If Not c Is Nothing And s2.Range("X1") <> "" Then
        adres = c.Address
        s2.Range("A2:V" & s2.Cells(Rows.Count, "A").End(3).Row).ClearContents
        Do
            ss2 = s2.Cells(Rows.Count, "A").End(3).Row + 1
            s1.Range(Cells(c.Row, 1).Address, Cells(c.Row, 20).Address).Copy s2.Range("A" & ss2)
            Set c = s1.Cells.FindNext(c)
        Loop While Not c Is Nothing And c.Address <> adres
        Exit Sub
    End If
    MsgBox s2.Range("X1").Value & " Profil Numarası Kayıtlı değil.", vbCritical, "DİKKAT"
    s2.Range("X1") = ""
End Sub

çalışıyor. teşekkürler

u ve v verileri gelmiyor

 

[dEdE]

u ve v verileri gelmiyor

Dikkatsizlik işte. Gözümden kaçmış. s1.Range(Cells(c.Row, 1).Address, Cells(c.Row, 20).Address).Copy s2.Range("A" & ss2) satırındaki 20 sayısını 22 yapmanız yeterli olacaktır.

 

[Faulkner]

Dikkatsizlik işte. Gözümden kaçmış. s1.Range(Cells(c.Row, 1).Address, Cells(c.Row, 20).Address).Copy s2.Range("A" & ss2) satırındaki 20 sayısını 22 yapmanız yeterli olacaktır.

Estağfurullah. Elinize sağlık.

Peki bir sorum daha olacaktı.

İstediğim kodda 22 başlıkta geliyor. Mesela istediğim başlıkları getirmesini istesem a sütünü c sütünü vs kod da nasıl yapılır yardımcı olur musunuz. Teşekkürler

 

[dEdE]

Merhaba,
Balık vermek yerine, balık tutmayı öğretmeyi tercih ederim.
s1.Range(Cells(c.Row, 1).Address, Cells(c.Row, 22).Address).Copy s2.Range("A" & ss2) satırının yerine birkaç satır yazmak gerekir.
Örneğin; s2.Cells(ss2, 1) = s1.Cells(c.Row, 5) satırı, Güncel isimli sayfanın E sütunundaki(5. sütun) verileri Sayfa1 adlı sayfanın A sütununun boş olan ilk satırına yazar.
Aynı mantıkla diğer satırları yazabileceğinizi değerlendiriyorum.

 

[Faulkner]

Merhaba,
Balık vermek yerine, balık tutmayı öğretmeyi tercih ederim.
s1.Range(Cells(c.Row, 1).Address, Cells(c.Row, 22).Address).Copy s2.Range("A" & ss2) satırının yerine birkaç satır yazmak gerekir.
Örneğin; s2.Cells(ss2, 1) = s1.Cells(c.Row, 5) satırı, Güncel isimli sayfanın E sütunundaki(5. sütun) verileri Sayfa1 adlı sayfanın A sütununun boş olan ilk satırına yazar.
Aynı mantıkla diğer satırları yazabileceğinizi değerlendiriyorum.

dediğiniz gibi uyguladım. teşekkürler