Stok Farkları İçin Yardım

[eyceda]

Arkadaşlar Merhaba,

Ekli Dosyanın Rapor sekmesinde yapmak istediğim konuyu ayrıntılı olarak yazdım vba konusunda fazla bilgim olmadığından sizlerin yardımını rica ederim.

Şimdiden teşekkürler...

 

[musculus]

Kullandığın excel 2007 mümkünse 2003 olarak kayır edip dosyayı tekrar eklermisin

 

[eyceda]

Düzelttim arkadaşlar kusra bakmayın

 

[Orion1]

Dosyanız hazır..

Sub rapor()
Dim k As Range, j As Byte, ilk_adres As String
Dim kod As String, a As Long
Sheets("TABLO").Select
kod = InputBox("Raporlanacak Ürünün Kodunu Giriniz..!!", "RAPOR")
If kod = "" Then Exit Sub
sat = 2
ReDim myarr(1 To 4, 1 To 1)
Set k = Range("A2:A65536").Find(kod, , xlValues, xlWhole, , 1)
If Not k Is Nothing Then
    ilk_adres = k.Address
    Do
        a = a + 1
        ReDim Preserve myarr(1 To 4, 1 To a)
        For j = 1 To 4
            myarr(j, a) = Cells(k.Row, j).Value
        Next j
        Set k = Range("A2:A65536").FindNext(k)
    Loop While Not k Is Nothing And k.Address <> ilk_adres
End If
Sheets("rAPOR").Select
Application.ScreenUpdating = False
Range("A2:E65536").ClearContents
If a > 0 Then
    [A2].Resize(a, 4) = Application.Transpose(myarr)
End If
Application.ScreenUpdating = True
If a > 0 Then
    MsgBox a & " Adet listeleme yapıldı..", vbOKOnly, Application.UserName
End If
End Sub

 

[Orion1]

Sayın eyceda yalnız 1 defa listelenenler listeleniyor.
Ekli dosyayı deneyiniz.

Sub benzersizler()
Dim hucre As Range, a As Long, c As Byte, sat As Long
Sheets("TABLO").Select
ReDim myarr(1 To 5, 1 To 1)
For Each hucre In Range("A2:A" & Cells(65536, "A").End(xlUp).Row)
    If WorksheetFunction.CountIf(Range("A2:A65536"), hucre.Value) = 1 Then
        a = a + 1
        ReDim Preserve myarr(1 To 5, 1 To a)
        sat = sat + 1
        myarr(1, a) = sat
        For c = 2 To 5
            myarr(c, a) = hucre.Offset(0, c - 2).Value
        Next c
    End If
Next hucre
Application.ScreenUpdating = False
Sheets("rAPOR").Select
Range("A2:E65536").ClearContents
If a > 0 Then
    [A2].Resize(a, 5) = Application.Transpose(myarr)
End If
Application.ScreenUpdating = True
If a > 0 Then
    MsgBox a & " Adet Benzersiz listelendi..!!", vbOKOnly + vbInformation, Application.UserName
    Else
    MsgBox "Benzesiz Kayıt bulunamadı..!!", vbOKOnly + vbInformation, "KAYIT BULUNAMADI..!!"
End If

        
End Sub

 

[eyceda]

Sn. Evren ilginize ve yardımınıza çok teşekkür ederim büyük yükten kurtuldum tekrar teşekkür..

 

[Orion1]

Sn. Evren ilginize ve yardımınıza çok teşekkür ederim büyük yükten kurtuldum tekrar teşekkür..

Rica ederim.
İyi çalışmalar.