Koli Listesini Adreslerine Göre Parçalara Bölme

[ismail-34]

Excel web Ailesine Saygılar Sevgiler.

Benim şöyle bir sorum var. Biz gümrüğe fatura keserken tek parça kolileri fatura ediyoruz.ancak pratikte o kolilerin ayrılarak farklı müşterilere gitmesi gerekiyor. Dolayısıyla her seferinde mevcut listeyi 2 veya en fazla 3 e bölerek üstlerinede adres yazarak farklı bir koli listesi düzenlemem gerekiyor.

Örnekteki gibi Toplu Koli Listesinin ayrılarak Ayrılmış Koliler Sekmesindeki gibi olmasını istiyorum.Bu bana bayağı vakitten tasarruf kazandıracak.

Örnek Ektedir. Herkese İyi Günler Dilerim.

 

[veyselemre]

Sub test()
    Dim dic As Object, ky$, adr$, i&, ii%, ver, sat&
    Sheets("Toplu Koli Listesi").Select
    Set dic = CreateObject("Scripting.Dictionary")
    With dic
        For i = 2 To Cells(Rows.Count, 1).End(3).Row
            ky = Cells(i, "F").Value
            adr = ""
            If Not .exists(ky) Then
                For ii = 13 To Cells(2, Columns.Count).End(xlToLeft).Column
                    If Cells(2, ii).Value = ky Then
                        adr = Cells(3, ii).Value
                        Exit For
                    End If
                Next
                .Item(ky) = Array(i, i, adr, ky)
            Else
                ver = .Item(ky)
                ver(1) = i
                .Item(ky) = ver
            End If
        Next i
        Sheets("AYRILMIŞ KOLİLER").Select
        Cells.Clear
        With Sheets("Toplu Koli Listesi")
            sat = 1
            For Each ver In dic.items
                Cells(sat, "C").Value = ver(3)
                Cells(sat + 1, "C").Value = ver(2)
                .Range("A1:E1").Copy Cells(sat + 3, 1)
                .Range("A" & ver(0) & ":E" & ver(1)).Copy Cells(sat + 4, 1)
                Cells(sat + 4, 1).Value = 1
                Range("A" & sat + 4 & ":A" & sat + ver(1) - ver(0) + 4).DataSeries
                sat = sat + ver(1) - ver(0) + 7
            Next ver
        End With
        Columns.AutoFit
    End With
End Sub

 

[ismail-34]

hocam neden özel üye olduğunuzu daha iyi idrak ettim. Saat gibi çalışıyor.çok ama çok teşekkür eder, saygılarımı sunarım ..

Sadece tek sorum olacak.benim kolilerin içinde birden fazla çeşit olduğundan bazı kolilerde aynı koli numaralarından tekrarları var.örnektede bunu görebilirsiniz. onlarıda aynı toplu listedeki gibi tekrarlı olanları aktarabilirmiyiz ? Sıralamaya aykırı bir durum ama koli numaralarında tekrarlı olanlar var malesef çünkü bir kolideki farklı mallar bu şekilde belirtiliyor ihracat işlerinde..zaten tekrarlı koliler hesaba katılmadığından örneğin 3. müşterinin koli sayısının 4 olması gerekirken 7 olarak hesaplanıyor.

 

[veyselemre]

Sub test()
    Dim dic As Object, ky$, adr$, i&, ii%, ver, sat&, fark
    Sheets("Toplu Koli Listesi").Select
    Set dic = CreateObject("Scripting.Dictionary")
    With dic
        For i = 2 To Cells(Rows.Count, 1).End(3).Row
            ky = Cells(i, "F").Value
            adr = ""
            If Not .exists(ky) Then
                For ii = 13 To Cells(2, Columns.Count).End(xlToLeft).Column
                    If Cells(2, ii).Value = ky Then
                        adr = Cells(3, ii).Value
                        Exit For
                    End If
                Next
                .Item(ky) = Array(i, i, adr, ky)
            Else
                ver = .Item(ky)
                ver(1) = i
                .Item(ky) = ver
            End If
        Next i
        Sheets("AYRILMIŞ KOLİLER").Select
        Cells.Clear
        With Sheets("Toplu Koli Listesi")
            sat = 1
            For Each ver In dic.items
                Cells(sat, "C").Value = ver(3)
                Cells(sat + 1, "C").Value = ver(2)
                .Range("A1:E1").Copy Cells(sat + 3, 1)
                .Range("A" & ver(0) & ":E" & ver(1)).Copy Cells(sat + 4, 1)
                fark = (Cells(sat + 4, 1).Value - 1) * -1
                Cells(sat + 2, 1).Value = fark
                Cells(sat + 2, 1).Copy
                Range("A" & sat + 4 & ":A" & sat + ver(1) - ver(0) + 4).PasteSpecial xlPasteValues, xlPasteSpecialOperationAdd
                Cells(sat + 2, 1).ClearContents
                sat = sat + ver(1) - ver(0) + 7
            Next ver
        End With
        Columns.AutoFit
    End With
End Sub

 

[ismail-34]

Sub test()
    Dim dic As Object, ky$, adr$, i&, ii%, ver, sat&, fark
    Sheets("Toplu Koli Listesi").Select
    Set dic = CreateObject("Scripting.Dictionary")
    With dic
        For i = 2 To Cells(Rows.Count, 1).End(3).Row
            ky = Cells(i, "F").Value
            adr = ""
            If Not .exists(ky) Then
                For ii = 13 To Cells(2, Columns.Count).End(xlToLeft).Column
                    If Cells(2, ii).Value = ky Then
                        adr = Cells(3, ii).Value
                        Exit For
                    End If
                Next
                .Item(ky) = Array(i, i, adr, ky)
            Else
                ver = .Item(ky)
                ver(1) = i
                .Item(ky) = ver
            End If
        Next i
        Sheets("AYRILMIŞ KOLİLER").Select
        Cells.Clear
        With Sheets("Toplu Koli Listesi")
            sat = 1
            For Each ver In dic.items
                Cells(sat, "C").Value = ver(3)
                Cells(sat + 1, "C").Value = ver(2)
                .Range("A1:E1").Copy Cells(sat + 3, 1)
                .Range("A" & ver(0) & ":E" & ver(1)).Copy Cells(sat + 4, 1)
                fark = (Cells(sat + 4, 1).Value - 1) * -1
                Cells(sat + 2, 1).Value = fark
                Cells(sat + 2, 1).Copy
                Range("A" & sat + 4 & ":A" & sat + ver(1) - ver(0) + 4).PasteSpecial xlPasteValues, xlPasteSpecialOperationAdd
                Cells(sat + 2, 1).ClearContents
                sat = sat + ver(1) - ver(0) + 7
            Next ver
        End With
        Columns.AutoFit
    End With
End Sub

HOCAM KUSRA BAKMAYIN AMA RESMEN SANAT ESERİ OLMUŞ TAM İSTEDİĞİM GİBİ SAĞOLUN VAROLUN DEĞERLİ ÇOK ÖZEL ÜYE HOCAMMMMM..