• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Kodun son 2 rakkamına gore yenıden lıstelemek

A

Alpay Black

Katılım
31 Ekim 2006
Mesajlar
131
Excel Vers. ve Dili
excel 2010 ve 2013
Arkadalar elımdekı lıstede farklı kodlar var.
Benım ıstedıgım sonu 51 ıle bıtenlerı malzeme adı ıle bırlıkte sayfa 2 ye
54 ıle bıtenlerı sayfa 3 76 ıle bıtenlerı sayfa 4
yazdırmak ıstıyorum malzeme adı ıle bırlıkte
bu konuda yardımlarınızı beklıyorum. Teşekkur ederım dosya ektedır ornek olarak
 

Ekli dosyalar

.

Makrolar ile daha kolay bir çalışma olabilir.

.
 
Merhaba,

Formülle de yapılabilir, fakat bu tür yapılarda makro kullanmak daha doğru olacaktır.
Bu şekilde deneyin.

Kod: 
Sub Sartli_Listele()
    
    Dim deg(), syf(), i As Long, j As Byte, sat As Long
    
    deg = Array("51", "01", "76", "54")
    syf = Array("Sayfa2", "Sayfa3", "Sayfa4", "Sayfa5")
    
    Application.ScreenUpdating = False
    Sheets("Sayfa1").Select
    
    For j = 0 To UBound(syf)
        Sheets(syf(j)).Range("A2:B" & Rows.Count).Clear
    Next j

    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        For j = 0 To UBound(deg)
            If Right(Cells(i, "A"), 2) = deg(j) Then
                sat = Sheets(syf(j)).Cells(Rows.Count, "A").End(xlUp).Row + 1
                Cells(i, "A").Resize(1, 2).Copy _
                    Sheets(syf(j)).Cells(sat, "A")
                Exit For
            End If
        Next j
    Next i
    
    Application.ScreenUpdating = True
    
End Sub

.
 
hocam runtıöe error 9 subscript out of range dıye hata verıyor
 
syf tanımındaki sayfa adları sizin dosyanız da var mı? Yada isimleri doğru mu?
 
ömer' Alıntı:
syf tanımındaki sayfa adları sizin dosyanız da var mı? Yada isimleri doğru mu?
Genişletmek için tıkla ...
hocam sayfa 4 ve 5 acmadıgım ıcın vermıs hatayı teşekkur ederım
bırde bu kodları sayfa ısımlerını verdıgımsurece cogalta bılırım dımı


yardımlarından dolayı tesekkur ederım
 
Sayfa ismi ve ölçütleri aynı düzeyde istediğiniz kadar artırabilirsiniz.

.
 
Sayfaya aktarılanlar kalıcı mı olacak? Çünkü ben onları her defasında sildirmek için komut yazmıştım.
Kalıcı hali getirip, aktarım işlemiden sonra Sayfa1 deki verileri sildirmek için ilave eklenmiştir.

Kod: 
Sub Sartli_Listele()
    
    Dim deg(), syf(), i As Long, j As Byte, sat As Long
    
    deg = Array("51", "01", "76", "54")
    syf = Array("Sayfa2", "Sayfa3", "Sayfa4", "Sayfa5")
    
    Application.ScreenUpdating = False
    Sheets("Sayfa1").Select
    
    'For j = 0 To UBound(syf)
     '   Sheets(syf(j)).Range("A2:B" & Rows.Count).Clear
    'Next j

    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        For j = 0 To UBound(deg)
            If Right(Cells(i, "A"), 2) = deg(j) Then
                sat = Sheets(syf(j)).Cells(Rows.Count, "A").End(xlUp).Row + 1
                Cells(i, "A").Resize(1, 2).Copy _
                    Sheets(syf(j)).Cells(sat, "A")
                Exit For
            End If
        Next j
    Next i
    
    Range("A2:B" & Rows.Count).ClearContents 'verileri silmek için ilave
    
    Application.ScreenUpdating = True
    
End Sub

.
 
. . .

saridikkat.png


Örneğin hücredeki değer 12345
koddaki tanımlamalarda 45 ve yeni aktarılacağı sayfa yoksa.
Bu veriyi başka bir alana almadan silecektir. Dikkat ediniz...

. . .
 
hocam elıne sağlık ama tum verılerı sılıyor .
benım ıstedıgım ıse sadece tasına verıler sılınsın taşınmayan verıler kalsın
 
Bu şekilde deneyin.

Kod: 
Sub Sartli_Listele()
    
    Dim deg(), syf(), i As Long, j As Byte, sat As Long
    
    deg = Array("51", "01", "76", "54")
    syf = Array("Sayfa2", "Sayfa3", "Sayfa4", "Sayfa5")
    
    Application.ScreenUpdating = False
    Sheets("Sayfa1").Select

    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        For j = 0 To UBound(deg)
            If Right(Cells(i, "A"), 2) = deg(j) Then
                sat = Sheets(syf(j)).Cells(Rows.Count, "A").End(xlUp).Row + 1
                Cells(i, "A").Resize(1, 2).Copy _
                    Sheets(syf(j)).Cells(sat, "A")
                Cells(i, "A").Resize(1, 2).ClearContents
                Exit For
            End If
        Next j
    Next i
    
    Application.ScreenUpdating = True
    
End Sub

.
 
ömer' Alıntı:
bu şekilde deneyin.

Kod: 
sub sartli_listele()
    
    dim deg(), syf(), i as long, j as byte, sat as long
    
    deg = array("51", "01", "76", "54")
    syf = array("sayfa2", "sayfa3", "sayfa4", "sayfa5")
    
    application.screenupdating = false
    sheets("sayfa1").select

    for i = 2 to cells(rows.count, "a").end(xlup).row
        for j = 0 to ubound(deg)
            ıf right(cells(i, "a"), 2) = deg(j) then
                sat = sheets(syf(j)).cells(rows.count, "a").end(xlup).row + 1
                cells(i, "a").resize(1, 2).copy _
                    sheets(syf(j)).cells(sat, "a")
                cells(i, "a").resize(1, 2).clearcontents
                exit for
            end ıf
        next j
    next i
    
    application.screenupdating = true
    
end sub

.
Genişletmek için tıkla ...
hocam cok teşekkur ederım ıstedıgım buydu saolun var olun. ama bır sorum daha var cok yoruyorum sızı bu sorum bıraz karışık dosya ektedır
 

Ekli dosyalar

Son düzenleme:
Ömer hocam bır sorum daha var cok yoruyorum sızı bu sorum bıraz karışık dosya ektedır
 

Ekli dosyalar

Diğer kodun yanında ilave olarak sadece ilk 10 rakamı eşit olanların tümünü farklı bir sayfada mı toplamak istiyorsunuz. Eşit olan yoksa bir işlem olmayacak sanırım.

.
 
ömer' Alıntı:
diğer kodun yanında ilave olarak sadece ilk 10 rakamı eşit olanların tümünü farklı bir sayfada mı toplamak istiyorsunuz. Eşit olan yoksa bir işlem olmayacak sanırım.

.
Genişletmek için tıkla ...

evet hocam ılk 10 rakkamı aynı olanları farklı bir sayfaya yazacak BİRDE IMKAN VARSA BUTUN SAYFALARI TARAYIP BULDUGU KODALARI VE KODLARIN YANINA SIMLERIVE HANGI SAYFADA OLDUGUNU
 
Bu şekilde deneyin.
Tekrar edenleri Sayfa6'ya listeler.

Kod: 
Sub Sartli_Listele()
    
    Dim deg(), syf(), i As Long, j As Byte, sat As Long, dizi(), a

    deg = Array("51", "01", "76", "54")
    syf = Array("Sayfa2", "Sayfa3", "Sayfa4", "Sayfa5")
    
    Application.ScreenUpdating = False
    Sheets("Sayfa1").Select

    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        For j = 0 To UBound(deg)
            If Right(Cells(i, "A"), 2) = deg(j) Then
                sat = Sheets(syf(j)).Cells(Rows.Count, "A").End(xlUp).Row + 1
                Cells(i, "A").Resize(1, 2).Copy _
                    Sheets(syf(j)).Cells(sat, "A")
                Cells(i, "A").Resize(1, 2).ClearContents
                Exit For
            End If
        Next j
    Next i
    
    For j = 0 To UBound(syf)
        With Sheets(syf(j))
            For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
                a = a + 1
                ReDim Preserve dizi(1 To 3, 1 To a)
                dizi(1, a) = Left(.Cells(i, "A"), 10)
                dizi(2, a) = .Cells(i, "B")
                dizi(3, a) = .Name
            Next i
        End With
    Next j
    
    Sheets("Sayfa6").Select
    Range("A2:C" & Rows.Count).ClearContents

    sat = 2
    For i = 1 To a
        If Application.Count(Application.Match(dizi, _
                Array(dizi(1, i)), 0)) > 1 Then
            Cells(sat, "A") = dizi(1, i)
            Cells(sat, "B") = dizi(2, i)
            Cells(sat, "C") = dizi(3, i)
            sat = sat + 1
        End If
    Next i
    
    Application.ScreenUpdating = True
    
End Sub

.
 
Hocam ıslem dogru fakat hata fvar her malzeme kodunu kendı sayfasına 2 kere yazıyorve 6 sayfada da dogal olarak 2 ser adet gosteerıyor bır bakarmısınız
 
Telefondan yazdığım için şu an bakma şansım yok fakat hatırladığım kadarıyla;
Eklediğiniz dosyada sayfalarda veri vardı. Bu aynı verilerin üzerine siz tekrar aktarma yaptığınız için aktarım o şekilde oluyordur.

Kontrol edermisiniz.
 
ömer' Alıntı:
telefondan yazdığım için şu an bakma şansım yok fakat hatırladığım kadarıyla;
eklediğiniz dosyada sayfalarda veri vardı. Bu aynı verilerin üzerine siz tekrar aktarma yaptığınız için aktarım o şekilde oluyordur.

Kontrol edermisiniz.
Genişletmek için tıkla ...
tmm hocam dogru cok teşekkur ederım
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst