• DİKKAT

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

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

  • Konbuyu başlatan Konbuyu başlatan huzun77
  • Başlangıç tarihi Başlangıç tarihi
H

huzun77

Katılım
8 Ekim 2018
Mesajlar
19
Excel Vers. ve Dili
EXCEL 97-2003 , TÜRKÇE
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,
 

Ekli dosyalar

Konu ilgili foruma tarafımdan taşınmıştır...
 
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.
Rich (BB code): 
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
 
Son düzenleme:
Ömer BARAN' Alıntı:
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.
Rich (BB code): 
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
Genişletmek için tıkla ...

Ö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
 
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.
Rich (BB code): 
......................................
ason = Cells(Rows.Count, 1).End(3).Row
......................................
For sat = 3 To ason
......................................
 
Ömer BARAN' Alıntı:
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.
Rich (BB code): 
......................................
ason = Cells(Rows.Count, 1).End(3).Row
......................................
For sat = 3 To ason
......................................
Genişletmek için tıkla ...
bu seferde
run yaptığım zaman subscrıption out of range error veriyor ,
 
Alternatif kod.

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
 
çok teşekkür ederim üstad

iyi çalışmalar
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst