EXCEL TABLO ÜRÜN VE FT GİTİP NO AYRIM

[huzun77]

Mehaba,

ekteki tabloda hücrelerdeki ürünleri ve gtip nolarını ayrı satırlarda gösterebilirmiyim

yardımlarınız için şimdiden teşekkürler

saygılar,

 

[turist]

Sorunuzu yanlış yerde soruyorsunuz.
EXCEL-Soruları
kısmında
Excel'e Yeni Başlayanlar
Fonksiyon Soruları
Makro-VBA Soruları
Grafik Soruları
Diğer Excel Soruları
Başlıkları altında bir konu olarak sorunuz.

 

[Korhan Ayhan]

Konu ilgili foruma tarafımdan taşınmıştır...

 

[Ömer BARAN]

Merhaba.

Alt taraftan, verilerin bulunduğu sayfanın adına (Sayfa1) fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin,
açılan VBA ekranında sağdaki boş alana aşağıdaki kod blokunu yapıştırıp, çalıştırın.
İşlem hızı, veri miktarına göre değişecektir.

Sub GTIP_AYIR()
If Cells(Rows.Count, "L").End(3).Row > 2 Then Range("L3:T" & Rows.Count).ClearContents
ason = Cells(Rows.Count, 1).End(3).Row: [Q:Q].NumberFormat = "@"
zaman = Timer
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
For sat = 3 To ason
    adet = Len(Cells(sat, 5)) - Len(Replace(Cells(sat, 5), ",", ""))
    satt = Cells(Rows.Count, 16).End(3).Row + 1
    Range("A" & sat & ":D" & sat).Copy Range(Cells(satt, "L"), Cells(satt + adet, "O"))
    Range("H" & sat & ":J" & sat).Copy Range(Cells(satt, "R"), Cells(satt + adet, "T"))
        For s = 1 To adet
            Cells(satt, 16) = Split(Cells(sat, 5), ",")(s - 1)
            Cells(satt, 17) = Split(Cells(sat, 7), ",")(s - 1)
            Cells(satt + s, 16) = Split(Cells(sat, 5), ",")(s)
            Cells(satt + s, 17) = Split(Cells(sat, 7), ",")(s)
        Next
Next
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İŞLEM TAMAMLANDI." & vbLf & "İşlem Süresi :  " & _
        Format(Timer - zaman, "0.0") & "  saniye.", vbInformation, "..:: Ömer BARAN ::.."
End Sub

 

[huzun77]

Merhaba.

Alt taraftan, verilerin bulunduğu sayfanın adına (Sayfa1) fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin,
açılan VBA ekranında sağdaki boş alana aşağıdaki kod blokunu yapıştırıp, çalıştırın.
İşlem hızı, veri miktarına göre değişecektir.

Sub GTIP_AYIR()
If Cells(Rows.Count, "L").End(3).Row > 2 Then Range("L3:T" & Rows.Count).ClearContents
ason = Cells(Rows.Count, 1).End(3).Row: [Q:Q].NumberFormat = "@"
zaman = Timer
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
For sat = 3 To ason
    adet = Len(Cells(sat, 5)) - Len(Replace(Cells(sat, 5), ",", ""))
    satt = Cells(Rows.Count, 16).End(3).Row + 1
    Range("A" & sat & ":D" & sat).Copy Range(Cells(satt, "L"), Cells(satt + adet, "O"))
    Range("H" & sat & ":J" & sat).Copy Range(Cells(satt, "R"), Cells(satt + adet, "T"))
        For s = 1 To adet
            Cells(satt, 16) = Split(Cells(sat, 5), ",")(s - 1)
            Cells(satt, 17) = Split(Cells(sat, 7), ",")(s - 1)
            Cells(satt + s, 16) = Split(Cells(sat, 5), ",")(s)
            Cells(satt + s, 17) = Split(Cells(sat, 7), ",")(s)
        Next
Next
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İŞLEM TAMAMLANDI." & vbLf & "İşlem Süresi :  " & _
        Format(Timer - zaman, "0.0") & "  saniye.", vbInformation, "..:: Ömer BARAN ::.."
End Sub

Ömer Bey Merhaba,

Gönderdiğiniz makro çalıştı sorun yok,
fakat aynı tabloya ilave satırlar koyduğumda çalıştırdığımda ,tüm satırları almadı,
makroda değişiklik mi yapmak gerekiyor ? satır sayısı 8365 iken 9327 oldu

 

[Ömer BARAN]

Kod'un işlem yapacağı satırları belirleyen kısım aşağıdaki ason=.... satırı.
A sütunundaki son dolu satıra kadar işlem yapılır, kod'da değişiklik yapılması gerekmez.

......................................
ason = Cells(Rows.Count, 1).End(3).Row
......................................
For sat = 3 To ason
......................................

 

[huzun77]

Kod'un işlem yapacağı satırları belirleyen kısım aşağıdaki ason=.... satırı.
A sütunundaki son dolu satıra kadar işlem yapılır, kod'da değişiklik yapılması gerekmez.

......................................
ason = Cells(Rows.Count, 1).End(3).Row
......................................
For sat = 3 To ason
......................................

bu seferde
run yaptığım zaman subscrıption out of range error veriyor ,

 

[huzun77]

bu seferde
run yaptığım zaman subscrıption out of range error veriyor ,

ilave satırlardan sonraki dosya ektedir

 

[Ziynettin]

Alternatif kod.

Sub test()
Sheets("Sayfa1").Select
a = Range("A3:J" & Cells(Rows.Count, 1).End(3).Row).Value
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(a)
    deg1 = Split(a(i, 5), ",")
    For J = 0 To UBound(deg1)
        d(deg1(J)) = d(deg1(J)) + 1
    Next J
Next i
ReDim b(1 To Application.Sum(d.items) + 1, 1 To UBound(a, 2))
On Error Resume Next
say = 1
    For i = 1 To UBound(a)
        deg1 = Split(a(i, 5), ",")
        deg2 = Split(a(i, 7), ",")
        For J = 0 To UBound(deg1)
            b(say + J, 1) = a(i, 1)
            b(say + J, 2) = a(i, 2)
            b(say + J, 3) = a(i, 3)
            b(say + J, 4) = a(i, 4)
            b(say + J, 5) = deg1(J)
            b(say + J, 6) = deg2(J)
            b(say + J, 7) = a(i, 8)
            b(say + J, 8) = a(i, 9)
            b(say + J, 9) = a(i, 10)
        Next J
        say = say + J
    Next i
Application.ScreenUpdating = False
Range("L3:U" & Rows.Count).ClearContents
If say > 0 Then
    [Q3].Resize(say).NumberFormat = "@"
    [L3].Resize(say).NumberFormat = "yyy-mm-dd"
    [T3].Resize(say).NumberFormat = "yyy-mm-dd"
    [L3].Resize(say, UBound(a, 2)) = b
End If
Application.ScreenUpdating = True
MsgBox "İşlem tamam.", vbInformation
End Sub

 

[huzun77]

çok teşekkür ederim üstad

iyi çalışmalar