Liste verilerin, hedef hücreye dizilerek gönderilmesi

[EKREM1661]

Saygıdeğer hocalarım.! (Öncelikle hayırlı çalışmalar dileğiyle selam olsun..)

Ekli örnek dosya ile açıklamasını daha anlaşılır yaptım. Bir sayfadaki liste verilerin, veri kaynağı olarak kullanılan diğer bir sayfa hücresine dizilerek aktarılmasına ait bir uygulama mevcut.. Burada (örnek dosyada) fazladan yapılan bir işin, kod içerisinden çıkartılması ile ilgili.. Yardımcı olursanız çok makbule geçer..

 

[Korhan Ayhan]

Deneyiniz.

Private Sub CommandButton2_Click()
    Dim s1 As Worksheet: Set s1 = Sheets("VeriKaynağı")
    Dim s2 As Worksheet: Set s2 = Sheets("Sayfa2")
    Dim Say As Byte, Veri As Variant, Hucre As Range
    
    Application.ScreenUpdating = False
    
    Say = WorksheetFunction.CountA(Range("G12:G20"))
    
    If Say = 0 Then
        MsgBox "Lütfen önce veri girişini tamamlayınız!", vbCritical
        Exit Sub
    End If
    
    For Each Hucre In Range("G12:G20")
        If Hucre.Value <> "" Then
            If Veri = "" Then
                Veri = Hucre.Value
            Else
                Veri = Veri & "," & Hucre.Value
            End If
        End If
    Next
    
    If s1.Cells(s1.Range("A1") * 5, "N") = Empty Then
    If MsgBox("Hedef hücrede değer yok..! Yeni Değer Kaydedilsin mi..?", vbYesNo + vbExclamation, "Uyarı") = vbNo Then GoTo 10
    s1.Cells(s1.Range("A1") * 5, "N") = Veri
    MsgBox "İşlem tamamlanmıştır.", vbInformation, "B İ L G İ"
    Exit Sub
    End If
    
    If s1.Cells(s1.Range("A1") * 5, "N") <> Empty Then
        If MsgBox("Hedef hücrede değer var.. Yeni Değer ile Değiştirilsin mi..?", vbYesNo + vbExclamation, "Uyarı") = vbNo Then GoTo 10
        s1.Cells(s1.Range("A1") * 5, "N") = Veri
        MsgBox "İşlem tamamlanmıştır.", vbInformation, "B İ L G İ"
    Else
10:
        MsgBox "İşlem iptal edilmiştir.", vbInformation, "B İ L G İ"
        Exit Sub
    End If
    
    Application.ScreenUpdating = True
End Sub

 

[EKREM1661]

Korhan hocam, teşekkürler.. Çok makbule geçti, elinize ve bilginize sağlık..

Üstad.. Sizi meşgul etmeyecekse, konu ile ilgili size sormayı planladığım bir ayrıntı daha kaldı..

İleride; VeriKaynağı sayfasındaki veri satırları arasında boş olan 4'er satırı kaldıracak olsak, yukarıdaki kod içerisinde nasıl bir değişiklik gerekir..

 

[Korhan Ayhan]

Kodların içinde "* 5" olan bölümler aralardaki boş satırları temsil ediyor.

 

[EKREM1661]

Hocam, onu ben denemiştim, fakat şöyle bir durum var. Sayfa başındaki sütun/konu başlıklarını ifade eden ilk 4 satırı atladıktan sonra başlaması gerekirken, (yerleşik satır numaralarını baz aldığı için) 2.nci satırdan itibaren saymaya/bulmaya başlıyor.

Başka bir deyişle; Sayfa2 den gönderilen veri A sütunundaki sıra numaraları karşısına gelmiyor. İlk 4 satırı hesap dışı tutması gerekiyor.

 

[EKREM1661]

güncel..

 

[Korhan Ayhan]

@EKREM1661,

Dosyanızı açtım. Açılır listeden "İsim 1" yazan seçeneği seçtim. Butona basıp veriyi aktar dediğimde N5 hücresine veriyi aktarıyor.

Sizin yaşadığınız sıkıntı nedir?

 

[EKREM1661]

Hocam, dosya şu haliyle yukarıdaki sizin kod ile uyumlu, burası tamam..

Ancak bu defa; İsim1, İsim2, İsim3,...... lerin arasında 4’er satır olan boş satırları kaldırıyoruz. Boş satır olmadan, yukarıdaki makroyu nasıl düzenleyebileceğimiz ile ilgiliydi.. Çünkü bu şekildeki dosyayı da kullanacağız da ondan..

Yani anlayacağınız, A sütunundaki sıra numaraları satır atlamayacak..

 

[EKREM1661]

Örnek dosyası..

 

[Korhan Ayhan]

@EKREM1661,

Siz açılan kutudan seçim yaptığınızda "VeriKaynağı" A1 hücresine seçimin sırası yazılıyor. Örneğin İsim 1 seçimini yaptığınızda hücreye 1 değerini yazıyor.

Siz veriyi aktarmak istediğinizde İsim 1 kaydı satır olarak 5. satırda olduğundan dolayı bu değeri elde etmek için 1+4 = 5 denklemini kurmanız yeterli olacaktır.

Kısaca kod içindeki * 1 olan yerleri + 4 olarak düzeltirseniz kod doğru aktarımı yapacaktır.

 

[EKREM1661]

Üstad.. Çok-çok teşekkürler.. Sağlık ve afiyetle hoşça kalınız..

 

[EKREM1661]

Korhan hocam.. Sizi tekrar meşgul etmek zorunda kaldım, ama konuyu önceden bildiğiniz için inşallah sizi işinizden etmez..
Sizin yukarıda verdiğiniz kodu, aynı işe birden fazlası için döngü kuramadım. Birleştirme yapınca da "GoTo 10" da takılıyor..
Ekli örneğe son kez bakabilirseniz!

 

[Korhan Ayhan]

Aktarım işlemi toplu olacağı için;

1- Renkli alandaki hücrelerin dolu olma durumu kontrol edilecek mi?
Örneğin "E" sütunu boş ise işlem diğer sütunlar için yapılmaya devam edecek mi?

2- Her sütun için uyarı mesajı verecek mi?
3- Aktarılacak sayfada hücre boşsa aktarım yapılıyor. Bu durum böylemi olması gerekiyor.

Kullanmak istediğiniz yapıyı bilmediğim için bu sorular önem arz ediyor. Belki açıklamanız gereken başka detaylarda vardır.

 

[EKREM1661]

Korhan üstadım.. Her sütun için kontrol mekanizması çalışsa daha iyi olacak gibi geliyor. En azından hedef hücrede veri var mı yok mu diye baştan bir kontrol iletisi olur.. Fakat yine de sen daha iyisini bilirsin..

1-Zaten dolu durumu ve boş durumunda evet denince, bir diğer sütuna geçmesi gerekiyor. Hayır denince işlem yapmıyor, fakat bu defa yine bir diğer sütuna geçiyor. Yani her iki durumda da diğer sütuna geçmesi elbet daha iyi olur.

2-Her sütun için uyarı mesajı verirse, kalması gereken veri üzerine aktarım olmamış olur.
3-Aktarılacak sayfada hücre boşsa aktarım yapmasında veri kaybı olmayacağı için sorun yok, durum böyle devam etsin..

Son satır cümlenizde haklısınız, sizin başınızı fazla yormamak için detaya girmedim. Açıklamalı küçültülmüş bir örnek ekledim.. Bakınca ne yapmak istediğimi göreceksiniz.

 

[EKREM1661]

Değerli hocam.. Sorduğunuz maddelere, yukarıda açıklama yaptım..

 

[Korhan Ayhan]

Ben işin her hücre için neden uyarı vermesi gerektiğini anlayamadım maalesef. Sonuçta aktarım yapılacaksa siz butona basıp işlemi başlatıyorsunuz. Her hücre için bir daha neden onay gerekiyor bunu anlayamadım.

Aşağıdaki kodu deneyiniz.

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Bul As Range
    Dim Sutun As Byte, Hucre As Range, Veri As String
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    
    Set Bul = S1.Range("A5:A" & S1.Rows.Count).Find(S1.Range("kaynak"), , , xlWhole)
    If Not Bul Is Nothing Then
        For Sutun = 4 To 7
            For Each Hucre In S2.Range(S2.Cells(12, Sutun), S2.Cells(20, Sutun))
                If Hucre.Value <> "" Then
                    If Veri = "" Then
                    Veri = Hucre.Value
                Else
                    Veri = Veri & "," & Hucre.Value
                    End If
                End If
            Next
            If Veri <> "" Then
                If S1.Cells(Bul.Row, Sutun + 7) <> Empty Then
                    If MsgBox("Hedef hücrede değer var!" & Chr(10) & "Yeni değer ile değiştirilsin mi?", vbYesNo + vbExclamation, "Uyarı") = vbNo Then GoTo 10
                    S1.Cells(Bul.Row, Sutun + 7) = Veri
                Else
                    If MsgBox("Hedef hücrede değer yok!" & Chr(10) & "Yeni değer kaydedilsin mi?", vbYesNo + vbExclamation, "Uyarı") = vbNo Then GoTo 10
                    S1.Cells(Bul.Row, Sutun + 7) = Veri
                End If
                Veri = ""
            End If
10      Next
    Else
        MsgBox "Seçtiğiniz kayıt bulunamadı!", vbCritical
    End If

    Set Bul = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
End Sub

 

[EKREM1661]

Değerli hocam.. Yukarıda, her hücrede uyarı verdirilmesine anlam veremediğiniz konusunda haklısınız, üstad.. Uygulama içerisinde görünce size hak verdim.. Dolayısıyla, özür beyanıyla birlikte, her şey için, tekrar teşekkürler.. Artık neyse kodları uyarlamaya çalışacağım. Sağlık ve selametle kalın..