boş sütünsuz süzme sayfası

[sinanco]

Değerli arkadaşlar,
ekli dosyada sayfa1 deki gibi bir tablom olsun. istenen: bu tabloda a sütünundaki bir hücreye tıklandığında (örn. a3) aynı satırdaki boş hücrelerden arınmış bir tablo (o ürünün reçetesi) sayfa 2 de oluşmuş olsun.
yardımlarınız için şimdiden teşekkürler.
saygılarımla
sinanco

 

[leumruk]

Merhaba,
Aşağıdaki kodu sayfa1'in kod bölümüne kopyalayın.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [A:A]) Is Nothing Or Target = "" Then Exit Sub
Cancel = True
Set s2 = Sheets("Sayfa2")
s2.Rows("1:2").ClearContents
For x = 1 To 13
If Cells(Target.Row, x) <> "" Then
Sut = Sut + 1
s2.Cells(1, Sut) = Cells(1, x)
s2.Cells(2, Sut) = Cells(Target.Row, x)
End If
Next
MsgBox "İşlem tamam.", vbInformation
End Sub

 

[Orion1]

Dosyanız ektedir.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim sat As Long, sut As Integer
If Intersect(Target, Range("A2:A" & Cells(65536, "A").End(xlUp).Row)) Is Nothing Then Exit Sub
With Sheets("Sayfa2")
    Cancel = True
    sat = .Cells(65536, "A").End(xlUp).Row + 1
    If sat >= 65533 Then
        MsgBox "Sayfa2'de satır doldu başka kayıt giremezsiniz.", vbCritical, "UYARI EVREN"
        Exit Sub
    End If
    sut = 2
    .Cells(sat, "A").Value = Target.Value
    For i = 2 To Cells(Target.Row, "IV").End(xlToLeft).Column
        If Cells(Target.Row, i).Value <> "" Then
            .Cells(sat, sut).Value = Cells(Target.Row, i).Value
            sut = sut + 1
        End If
    Next i
End With
            
End Sub

 

[sinanco]

Değerli arkadaşlar,
yardımlarınız için çok teşekkürler.
saygılarımla
sinanco