Koşula göre hücreler arası veri aktarımı

[patroklos]

Hücre içindeki değere göre dikey olarak sıraladığım listenin yatay olana aktarılmasını ve dikey listenin bir sonraki veri girişi için boşaltılmasını nasıl sağlayabilirim.

 

[Ergün Güler]

Selam,
dosyanızı 2003 formatında günceller misiniz?

 

[patroklos]

Merhaba Ergün Bey, 2003 Formatinda dosyayi güncelledim.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu sayfanın kod bölümüne uygulayıp denermisiniz. K sütununa veri girişi yaptıktan sonra K11 hücresine EVET yazıp enter tuşuna bastığınızda kod devreye girecektir.

Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim X As Byte, Y As Byte, Satır As Long
    If Intersect(Target, [K11]) Is Nothing Then Exit Sub
    If Target = Empty Then Exit Sub
        If WorksheetFunction.CountA(Range("K3:K9")) = 0 Then
            MsgBox "Kayıt işlemi için veri girişi yapmalısınız !" & Chr(10) & _
            "İşleminiz iptal edilmiştir.", vbCritical
            Range("K11") = Empty
            Exit Sub
        End If
    
    Satır = Range("A65536").End(3).Row + 1
        
    For X = 3 To 9
        If Cells(X, "J") <> "" Then
            For Y = 2 To 7
                If Cells(1, Y) = Cells(X, "J") Then
                    Cells(Satır, 1) = Range("K2")
                    Cells(Satır, Y) = Cells(X, "K")
                    Exit For
                End If
            Next
        End If
    Next
    
    Range("K3:K11") = Empty
    Range("K2") = Range("K2") + 1
 
    MsgBox "Kayıt işlemi tamamlanmıştır.", vbInformation
End Sub

 

[patroklos]

Korhan Bey, vermis oldugunuz kod icin tesekkür ederim. Fakat iki tane problem var. 1. Problem: K11'e Evet yazinca aktarim basarili ama bir hata veriyor(Run-Time Error "13" - Type mistmach).Debug tusuna basinca kodun If Target = Empty Then kismini sari renkle gösteriyor.(Excel 2007 kullaniyorum sorun oradan kaynaklanabilir mi?) 2. Problem: Gerci bu bir problem sayilmaz. Sira numarasinin (dikey olan listenin ilk hücresi) otomatik artmasi mümkün müdür ?

Ayrica bir sorum olacak bu kodu Evet yazmak yerine bir buton olusturup kullanabilirmiyim.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub KAYDET()
    Dim X As Byte, Y As Byte, Satır As Long
    
    If UCase(Range("K11")) = "EVET" Then
        If WorksheetFunction.CountA(Range("K3:K9")) = 0 Then
            MsgBox "Kayıt işlemi için veri girişi yapmalısınız !" & Chr(10) & _
            "İşleminiz iptal edilmiştir.", vbCritical
            Exit Sub
        End If
    
    Satır = Range("A65536").End(3).Row + 1
        
    For X = 3 To 9
        If Cells(X, "J") <> "" Then
            For Y = 2 To 7
                If Cells(1, Y) = Cells(X, "J") Then
                    Cells(Satır, 1) = Range("K2")
                    Cells(Satır, Y) = Cells(X, "K")
                    Exit For
                End If
            Next
        End If
    Next
    
    Range("K3:K11") = Empty
    Range("K2") = Range("K2") + 1
 
    MsgBox "Kayıt işlemi tamamlanmıştır.", vbInformation
    
    Else
    
    Range("K11").Select
    MsgBox "Lütfen alındı bilgi giriniz !", vbExclamation
    
    End If
End Sub

 

[Orion1]

Birleştirilmiş hücrelerde target komutu hata veriyor.
Zaten birleştiririlmiş hücreler vba yada ters geliyor.
Activecell kullanırsanız sorun çözülülecektir.

if Target=empty then

yerine

if activecell="" then

deneyiniz

 

[patroklos]

Korhan Bey, cok tesekkür ederim.Gönderdiginiz örnek tam istedigim gibi olmus. Evren Bey ilgilendiginiz icin sizede tesekkürler.

 

[patroklos]

Arka arkaya mesaj attigim icin öncellikle özür dilerim. Dünden bu ana kadar denememe ragmen Bu kodu kendi dosyama uygulayamadim. Bu nedenle sizi tekrar rahatsiz edecegim, kusura bakmayin. Dosyamdaki siralama A1 hücresinden degil F7 hücresinden basliyor. Zahmet olmazsa eger kodun degistirilmesi gereken yerini söylermisiniz.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu deneyin.

Option Explicit
 
Sub KAYDET()
    Dim X As Byte, Y As Byte, Satır As Long
    
    If UCase(Range("P21")) = "EVET" Then
        If WorksheetFunction.CountA(Range("Q8:Q20")) = 0 Then
            MsgBox "Kayıt işlemi için veri girişi yapmalısınız !" & Chr(10) & _
            "İşleminiz iptal edilmiştir.", vbCritical
            Exit Sub
        End If
    
    Satır = Range("E65536").End(3).Row + 1
        
    For X = 8 To 20
        If Cells(X, "P") <> "" Then
            For Y = 5 To 15
                If Cells(6, Y) = Cells(X, "P") Then
                    Cells(Satır, "E") = Range("Q7")
                    Cells(Satır, Y) = Cells(X, "Q")
                    Exit For
                End If
            Next
        End If
    Next
    
    Range("Q8:Q20") = Empty
    Range("Q7") = Range("Q7") + 1
 
    MsgBox "Kayıt işlemi tamamlanmıştır.", vbInformation
    
    Else
    
    Range("P21").Select
    MsgBox "Lütfen alındı bilgi giriniz !", vbExclamation
    
    End If
End Sub

 

[patroklos]

Çok teşekkür ederim. Sorun halloldu.