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

Katılım
29 Ocak 2014
Mesajlar
130
Excel Vers. ve Dili
OpenOffice,
Office 365,
Google Sheets,
Excel Vba
Altın Üyelik Bitiş Tarihi
24.12.2022
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
 
Son düzenleme:

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,167
Excel Vers. ve Dili
2019 Türkçe
Merhaba.

Kod:
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
 
Katılım
29 Ocak 2014
Mesajlar
130
Excel Vers. ve Dili
OpenOffice,
Office 365,
Google Sheets,
Excel Vba
Altın Üyelik Bitiş Tarihi
24.12.2022
merhaba,

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

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,167
Excel Vers. ve Dili
2019 Türkçe
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?
 
Katılım
29 Ocak 2014
Mesajlar
130
Excel Vers. ve Dili
OpenOffice,
Office 365,
Google Sheets,
Excel Vba
Altın Üyelik Bitiş Tarihi
24.12.2022
X1 hücresine profil numarası yazdığımda

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

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,167
Excel Vers. ve Dili
2019 Türkçe
Ö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

Destek Ekibi
Destek Ekibi
Katılım
1 Temmuz 2005
Mesajlar
2,605
Excel Vers. ve Dili
Ofis 2013 TR 64 Bit
Ben aşağıdaki gibi anladım.
Sayfanın kod bölümüne kopyalayıp dener misiniz?
C++:
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
 
Katılım
29 Ocak 2014
Mesajlar
130
Excel Vers. ve Dili
OpenOffice,
Office 365,
Google Sheets,
Excel Vba
Altın Üyelik Bitiş Tarihi
24.12.2022
Ö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.
 
Katılım
29 Ocak 2014
Mesajlar
130
Excel Vers. ve Dili
OpenOffice,
Office 365,
Google Sheets,
Excel Vba
Altın Üyelik Bitiş Tarihi
24.12.2022
Ben aşağıdaki gibi anladım.
Sayfanın kod bölümüne kopyalayıp dener misiniz?
C++:
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

Destek Ekibi
Destek Ekibi
Katılım
1 Temmuz 2005
Mesajlar
2,605
Excel Vers. ve Dili
Ofis 2013 TR 64 Bit
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.
 
Katılım
29 Ocak 2014
Mesajlar
130
Excel Vers. ve Dili
OpenOffice,
Office 365,
Google Sheets,
Excel Vba
Altın Üyelik Bitiş Tarihi
24.12.2022
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

Destek Ekibi
Destek Ekibi
Katılım
1 Temmuz 2005
Mesajlar
2,605
Excel Vers. ve Dili
Ofis 2013 TR 64 Bit
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.
 
Katılım
29 Ocak 2014
Mesajlar
130
Excel Vers. ve Dili
OpenOffice,
Office 365,
Google Sheets,
Excel Vba
Altın Üyelik Bitiş Tarihi
24.12.2022
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
 
Üst