Hücre boş ise sonraki hücreyi getir

[kayburcak]

Değerli üstadlar müşteriye aitverileri getirirken (boş hücreleri getirmeden) alt alta getirmesini ve kalan miktar girilince de data sayfasındaki yerine yazılmasını istiyorum.teşekkür ederim.

 

[askm]

Sub askm_aktar()
Dim s1, s2 As Worksheet
Dim SonSatir As Long
Set s1 = ThisWorkbook.Worksheets("Form")
Set s2 = ThisWorkbook.Worksheets("data")
s1.Range("A3:F65000").ClearContents
SonSatir = s2.Range("A65536").End(xlUp).Row
Aranan = s1.Range("e2").Value
Set Bul = s2.Range("A2:A" & SonSatir).Find(What:=Aranan, LookIn:=xlValues)
If Not Bul Is Nothing Then
        Satir = Bul.Row
End If
x = 3
For i = 2 To 41 Step 2
If s2.Cells(Satir, i) <> Empty Then
    s1.Cells(x, 1) = s2.Cells(1, i)
    s1.Cells(x, 5) = s2.Cells(Satir, i)
    s1.Cells(x, 6) = s2.Cells(Satir, i + 1)
    x = x + 1
End If
Next
MsgBox "İşleminiz tamamlanmıştır.", vbInformation, "ASKM"
End Sub

 

[kayburcak]

Sayın askm ilginize teşekkür ederim.Zannederim tam anlatamamışım.
Sadece satış olan rakamları getirecek.Kalan rakamları biz yazacağız
o rakamları data sayfasındaki yerine aktaracak.Bu şekilde olursa sevinirim.

 

[askm]

s1.Cells(x, 6) = s2.Cells(Satir, i + 1) satırını silerseniz sadece satışlar gelir.

 

[kayburcak]

Sayın Askm

Tekrar teşekkür ederim.O satır çıkınca sadece satışlar geliyor.
Satışların karşısına F sütununa kalanları yazıyoruz.Bu kalan rakamlarının
Data sayfasında satışların karşısına aktarılması gerekiyor.İlgilenirseniz memnun olurum.

 

[askm]

Aşağıdaki kodlar mı istediğiniz?

Sub askm_Aktar2()
Dim s1, s2 As Worksheet
Dim SonSatir As Long
Set s1 = ThisWorkbook.Worksheets("Form")
Set s2 = ThisWorkbook.Worksheets("data")
SonSatir = s1.Range("A65536").End(xlUp).Row
Aranan = s1.Range("e2").Value
Set Bul = s2.Range("A2:A" & SonSatir).Find(What:=Aranan, LookIn:=xlValues)
If Not Bul Is Nothing Then
        Satir = Bul.Row
End If

For i = 3 To SonSatir
    For x = 2 To 41
        If s2.Cells(1, x) = s1.Cells(i, 1) Then
            s2.Cells(Satir, x + 1) = s1.Cells(i, 6)
        End If
    Next x
Next i
MsgBox "Kalanları aktarma işleminiz tamamlanmıştır.", vbInformation, "ASKM"
End Sub

 

[ahmedummu]

Yeni konu açmak istiyorum. Nereden açabilirim.

 

[askm]

http://www.excel.web.tr/newthread.php?do=newthread&f=48 kırmından ya da http://www.excel.web.tr/f48/ kısmının sol üstünde yeni konu yazıyor. Oradan.

 

[kayburcak]

Sayın Askm

kodlar istediğim gibi çalıştı.Ellerine sağlık.Teşekkür ederim.Hayırlı ramazanlar..

 

[askm]

Hayırlı ramazanlar.