Veri aktarmada Boş Sütunu Aktarmayacak Dolu Sütunu aktaracak

[Ahmet Sami]

Arkadaşlar, VERİ sayfasından iki adet veri çekme sütunum var yani biri DMR.NO ve MALZEMENİN ADI Burada R1 sütununa yazdığım veriye göre VERİ sayfasındaki veriler gelecek ancak burada sizden istediğim yardımın bir tanesi verilerin H8:N1000 ARASINA GELMESİ ve şayet R1 'e girdiğim Malzeme adının veri sayfasındaki karşılığı olan sarı ile boyamış olduğum yer boş olduğundan o sütunun gelmemesi ancak sütunun sola doğru ötelenmesi örnek yandaki tabloda mevcuttur.
Örnek : HP TABLET leri aktardı ancak VERİ sayfasında CİNSİ sütunu boş olduğu için o sütun burda olmayacak yani örnekteki gibi olacak, başka bir sütun boş ise oda olmayacak
Tabloyu ekledim
Yardımlarınız için şimdiden teşekkür ederim.

 

[Ahmet Sami]

İyi günler, yukarıdaki açıklamam anlaşılmaz durumda ise yardımlarınız için şöyle söyleyeyim. Aktarma işlemini yaparken aktarılan verilerin karşılığında olan sütunlar aktarılmayacak B,C,D sütunu dolu E sütunu boş ve F,G sütunu dolu ise B,C,D,F,G sütununu aktaracak ancak aktarılan yerde sütun boşluğu olmayacak şekilde aktaracak yani E Sütununu aktarmayacak F sütunu dolu olduğu için F yi E sütununa aktaracak, umarım yardımcı olursunuz. Çok ihtiyacım var

 

[YUSUF44]

Aşağıdaki kodları ANASAYFA sayfasının kod bölümüne (sayfa adına sağ tıklayıp kod görüntüle deyince açılan sayfaya kopyalayıp deneyiniz. S1 hücresine veri girdiğinizde istediğiniz işlemi yapar:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [S1]) Is Nothing Then Exit Sub
If Selection.Count > 1 Then Exit Sub
If Target = "" Then Exit Sub
Set s1 = Sheets("VERİ")

son = s1.Cells(Rows.Count, "B").End(3).Row
eski = Cells(Rows.Count, "I").End(3).Row
Range("H7:N" & eski).Clear
If WorksheetFunction.CountIf(s1.Range("B1:B" & son), Target) = 0 Then
    MsgBox "Aranan kod VERİ sayfasında bulunmamaktadır!", vbCritical
Else
    s1.Range("$A$1:$G$" & son).AutoFilter Field:=2, Criteria1:=Target
    s1.Range("A1:G" & son).Copy [H7]
    
    For i = 14 To 8 Step -1
        
        If Cells(8, i) = "" Then
            Range(Cells(7, i), Cells(son + 8, i)).Delete Shift:=xlToLeft
        End If
    Next
    
    Columns("H:N").EntireColumn.AutoFit
    s1.Range("$A$1:$G$" & son).AutoFilter Field:=2

End If

End Sub

 

[Ahmet Sami]

Yusuf bey çok teşekkür ederim. Ayrıca S1 deki numaraya göre arama olmuş ayrıca R1 deki isme göre de yapabilirmiyiz yani Hem S1 deki noya göre hem R1 deki isme göre yani hangisini girersem onu aktarsın

 

[veyselemre]

Örneği inceleyiniz..

 

[YUSUF44]

Aşağıdaki kodları deneyiniz:

Private Sub Worksheet_Change(ByVal Target As Range)
If Selection.Count > 1 Then Exit Sub
Set s1 = Sheets("VERİ")
son = s1.Cells(Rows.Count, "B").End(3).Row
eski = Cells(Rows.Count, "I").End(3).Row

If Intersect(Target, Range("S1")) Is Nothing Then GoTo 10
    If Target = "" Then Exit Sub
    
    Range("H7:N" & eski).Clear
    
    If WorksheetFunction.CountIf(s1.Range("B1:B" & son), Target) = 0 Then
        MsgBox "Aranan kod VERİ sayfasında bulunmamaktadır!", vbCritical
    Else
        s1.Range("$A$1:$G$" & son).AutoFilter Field:=2, Criteria1:=Target
        s1.Range("A1:G" & son).Copy [H7]
        GoTo 20
    End If
10:
If Intersect(Target, Range("R1")) Is Nothing Then Exit Sub
    If Target = "" Then Exit Sub
    
    Range("H7:N" & eski).Clear
    
    If WorksheetFunction.CountIf(s1.Range("C1:C" & son), Target) = 0 Then
        MsgBox "Aranan malzeme VERİ sayfasında bulunmamaktadır!", vbCritical
    Else
        s1.Range("$A$1:$G$" & son).AutoFilter Field:=3, Criteria1:=Target
        s1.Range("A1:G" & son).Copy [H7]
        GoTo 20
    End If

20:
For i = 14 To 8 Step -1
    If Cells(8, i) = "" Then
        Range(Cells(7, i), Cells(son + 8, i)).Delete Shift:=xlToLeft
    End If
Next
    
Columns("H:N").EntireColumn.AutoFit
s1.Range("$A$1:$G$" & son).AutoFilter Field:=2
s1.Range("$A$1:$G$" & son).AutoFilter Field:=3

End Sub

 

[igultekin2000]

iki örnekte kullanışlı ve sorunsuz çalışor. Teşekkürler

 

[Ahmet Sami]

Yusuf bey teşekkür ederim emeğinize sağlık

Veysel bey dosyanızı indirdim ancak Rar hatası veriyor. Dosyayı açamıyorum tekrar yükleme imkanınız olursa sevinirim

 

[veyselemre]

Yusuf bey teşekkür ederim emeğinize sağlık

Veysel bey dosyanızı indirdim ancak Rar hatası veriyor. Dosyayı açamıyorum tekrar yükleme imkanınız olursa sevinirim

 

[Ahmet Sami]

Veysel Bey teşekkür ederim. Sağolun

 

[Ahmet Sami]

Yusuf bey, Veysel bey sizden bir istirhamım daha olacak ama umarım çok olmuyorumdur. Veriyi girince kendisi aktarmasından ziyade bir tuşla ben aktarsam olurmu. Bazen yanlış giriyorum hemen atıyor veya hata veriyor. Ancak R1 veya S1 'e veriyi girdikten sonra ayrı butonlarla tıklayarak aktarmak isityorum. Umarım yardımcı olursunuz teşekkür ederim.

 

[YUSUF44]

Aşağıdaki makroları deneyiniz:

Sub malzemekodu()
    Set s1 = Sheets("VERİ")
    Set s2 = Sheets("ANASAYFA")
    son = s1.Cells(Rows.Count, "B").End(3).Row
    eski = WorksheetFunction.Max(8, s2.Cells(Rows.Count, "I").End(3).Row)

    If s2.Range("S1") = "" Then Exit Sub
    
    s2.Range("H7:N" & eski).Clear
    
    If WorksheetFunction.CountIf(s1.Range("B1:B" & son), s2.Range("S1")) = 0 Then
        MsgBox "Aranan malzeme VERİ sayfasında bulunmamaktadır!", vbCritical
    Else
        s1.Range("$A$1:$G$" & son).AutoFilter Field:=2, Criteria1:=s2.Range("S1")
        s1.Range("A1:G" & son).Copy s2.[H7]
        GoTo 20
    End If

20:
For i = 14 To 8 Step -1
    If s2.Cells(8, i) = "" Then
        s2.Range(Cells(7, i), Cells(son + 8, i)).Delete Shift:=xlToLeft
    End If
Next
    
s2.Columns("H:N").EntireColumn.AutoFit
s1.Range("$A$1:$G$" & son).AutoFilter Field:=2
s1.Range("$A$1:$G$" & son).AutoFilter Field:=3

End Sub

Sub malzemeadi()
    Set s1 = Sheets("VERİ")
    Set s2 = Sheets("ANASAYFA")
    son = s1.Cells(Rows.Count, "B").End(3).Row
    eski = WorksheetFunction.Max(8, s2.Cells(Rows.Count, "I").End(3).Row)
    If s2.Range("R1") = "" Then Exit Sub
    
    s2.Range("H7:N" & eski).Clear
    
    If WorksheetFunction.CountIf(s1.Range("C1:C" & son), s2.Range("R1")) = 0 Then
        MsgBox "Aranan malzeme VERİ sayfasında bulunmamaktadır!", vbCritical
    Else
        s1.Range("$A$1:$G$" & son).AutoFilter Field:=3, Criteria1:=s2.Range("R1")
        s1.Range("A1:G" & son).Copy s2.[H7]
        GoTo 20
    End If

20:
For i = 14 To 8 Step -1
    If s2.Cells(8, i) = "" Then
        s2.Range(Cells(7, i), Cells(son + 8, i)).Delete Shift:=xlToLeft
    End If
Next
    
s2.Columns("H:N").EntireColumn.AutoFit
s1.Range("$A$1:$G$" & son).AutoFilter Field:=2
s1.Range("$A$1:$G$" & son).AutoFilter Field:=3

End Sub

 

[Ahmet Sami]

Yusuf bey teşekkür ederim. Sağolun sizlere zahmet verdik kusura bakmayın

 

[YUSUF44]

Eyvallah. İyi çalışmalar.