Excel Çalışma Sayfası Bilgileri Satırlara Aktarma

[gicimi]

Merhaba Arkadaşlar,

Excel çalışma sayfasında bulunan alt alta bilgileri satıra aktarma ve çıkarma işlemi yapma. Örnek belgede göstermeye çalıştım. Yardımlarınızı bekliyorum. Teşekkür ederim.

İyi Çalışmalar.

 

[muygun]

Merhaba;
Eki deneyin.
İyi çalışmalar.

 

[gicimi]

Merhaba;
Eki deneyin.
İyi çalışmalar.

Merhaba;

sonuç sayfasına 15, 85.... yazdığımda data sayfasındaki tüm bilgileri aktarıyor. Düzeltebilir miyiz ürün No kısmına 15 yazdığımda 15 bilgileri gelmesi gerekli yada 15,85 yazdığımda onun değerleri gelmeli hepsi geliyor.

 

[Orion1]

Dosyanız ektedir.

Sub akta_cikar59()
Dim i As Long, sonsat1 As Long, sonsat2 As Long
Dim sh As Worksheet, k As Range, sut1 As Byte, sut2 As Byte
Sheets("Sayfa1").Select
Set sh = Sheets("Sayfa2")
Range("E2:Q" & Rows.Count).ClearContents
sonsat1 = Cells(Rows.Count, "A").End(xlUp).Row
sonsat2 = sh.Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 2 To sonsat1
    Set k = sh.Range("A1:A" & Rows.Count).Find(Cells(i, "A").Value, , xlValues, xlWhole)
    If Not k Is Nothing Then
        adr = k.Address
        sut1 = 5
        sut2 = 11
        Do
            Cells(i, sut1).Value = k.Offset(0, 3).Value
            Cells(i, sut2).Value = k.Offset(0, 7).Value
            sut1 = sut1 + 1: sut2 = sut2 + 1
            Set k = sh.Range("A1:A" & Rows.Count).FindNext(k)
        Loop While Not k Is Nothing And k.Address <> adr
        Range("Q" & i).Value = Range("K" & i).Value - Range("E" & i).Value
    End If
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[gicimi]

Evren Bey çok teşekkür ederim. İyi Çalışmalar.

 

[Orion1]

Evren Bey çok teşekkür ederim. İyi Çalışmalar.

Rica ederim.
İyi çalışmalar.