Kolileri Firmalara Göre Tekrar Düzenle..

[ismail-34]

Çok Değerli Excell web ailesine selamlar sevgiler..

Ben bir kargo firmasında çalışıyorum.Ekteki dosyadaki gibi en fazla 3 firmanın olduğu listeyi her seferinde firma adına göre ayırma sekmesindeki formatta
düzenlemem gerekiyor. kolileri ve numaralarını (tekrarlayanlarıda algılayarak) tekrar numaralandırıp ayırma sayfasındaki gibi bir
sonucun elde edilmesi çok ama çok işime yarardı.

Örnek linktedir.

İndir firmaya göre koli ayırma

Dosyayı indir firmaya göre koli ayırma

dosya.co

Başta Tüm Değerli Hocalarıma olmak üzere bereketli günler temenni ederim..

 

[zehirlee]

İşini görürmü bilmem. Alttaki kodu geliştirici sekmesinden kod görüntüle kısmına yapıştır. sonrada çalıştır.
Sub Ayir()
Dim wsKaynak As Worksheet
Dim LastRow As Long
Dim i As Long
Dim Firma As String
Dim wsFirma As Worksheet
Dim RowIndex As Long

' Kaynak sayfasını tanımla
Set wsKaynak = ThisWorkbook.Sheets("Kaynak")

' Kaynak sayfadaki son satırı bul
LastRow = wsKaynak.Cells(wsKaynak.Rows.Count, "A").End(xlUp).Row

' Verileri firma bazında ayır
For i = 2 To LastRow
Firma = wsKaynak.Cells(i, 8).Value ' Firma adını al
Set wsFirma = Nothing

' Firma adına göre sayfa oluştur veya varsa mevcut sayfayı kullan
For Each ws In ThisWorkbook.Sheets
If ws.Name = Firma Then
Set wsFirma = ws
Exit For
End If
Next ws

If wsFirma Is Nothing Then
Set wsFirma = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
wsFirma.Name = Firma
wsFirma.Cells(1, 1).Value = "Koli No"
wsFirma.Cells(1, 2).Value = "KOD"
wsFirma.Cells(1, 3).Value = "MİKTAR"
wsFirma.Cells(1, 4).Value = "BİRİM"
wsFirma.Cells(1, 5).Value = "Cins."
wsFirma.Cells(1, 6).Value = "Ağırlık"
wsFirma.Cells(1, 7).Value = "Koli Ölçüleri"
wsFirma.Cells(1, 8).Value = "Firma"
RowIndex = 2
Else
RowIndex = wsFirma.Cells(wsFirma.Rows.Count, "A").End(xlUp).Row + 1
End If

' Veriyi firma sayfasına kopyala
wsKaynak.Rows(i).Copy Destination:=wsFirma.Rows(RowIndex)
Next i

MsgBox "Veriler firma bazında ayrıldı.", vbInformation
End Sub

 

[ismail-34]

İşini görürmü bilmem. Alttaki kodu geliştirici sekmesinden kod görüntüle kısmına yapıştır. sonrada çalıştır.
Sub Ayir()
Dim wsKaynak As Worksheet
Dim LastRow As Long
Dim i As Long
Dim Firma As String
Dim wsFirma As Worksheet
Dim RowIndex As Long

' Kaynak sayfasını tanımla
Set wsKaynak = ThisWorkbook.Sheets("Kaynak")

' Kaynak sayfadaki son satırı bul
LastRow = wsKaynak.Cells(wsKaynak.Rows.Count, "A").End(xlUp).Row

' Verileri firma bazında ayır
For i = 2 To LastRow
Firma = wsKaynak.Cells(i, 8).Value ' Firma adını al
Set wsFirma = Nothing

' Firma adına göre sayfa oluştur veya varsa mevcut sayfayı kullan
For Each ws In ThisWorkbook.Sheets
If ws.Name = Firma Then
Set wsFirma = ws
Exit For
End If
Next ws

If wsFirma Is Nothing Then
Set wsFirma = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
wsFirma.Name = Firma
wsFirma.Cells(1, 1).Value = "Koli No"
wsFirma.Cells(1, 2).Value = "KOD"
wsFirma.Cells(1, 3).Value = "MİKTAR"
wsFirma.Cells(1, 4).Value = "BİRİM"
wsFirma.Cells(1, 5).Value = "Cins."
wsFirma.Cells(1, 6).Value = "Ağırlık"
wsFirma.Cells(1, 7).Value = "Koli Ölçüleri"
wsFirma.Cells(1, 8).Value = "Firma"
RowIndex = 2
Else
RowIndex = wsFirma.Cells(wsFirma.Rows.Count, "A").End(xlUp).Row + 1
End If

' Veriyi firma sayfasına kopyala
wsKaynak.Rows(i).Copy Destination:=wsFirma.Rows(RowIndex)
Next i

MsgBox "Veriler firma bazında ayrıldı.", vbInformation
End Sub

eyw hocam buda biraz iş görür.sadece şunu öğrenmek istiyorum tüm satırı almasada 10.sütuna kadarki bölümü alabilirmi.xlineup tan ayarlanıor sanırım. çünkü sağ taraflarda başka şeyler var.

 

[veyselemre]

Sub advancedFilter()
    '08032024 veyselemre
    Dim rng As Range, firma, rngCriteria As Range, son&, sat&

    Sheets("Ayırma").Cells.Clear

    With Sheets("Veri")
        Set rng = .Range("A1:P" & .Cells(Rows.Count, 1).End(3).Row)
        Set rngCriteria = .Range("J1:J2")
        rngCriteria.Cells(1).Value = "Firma"
        rng.advancedFilter 2, .Range("H1"), .Range("J1"), True
        sat = 1
        For Each firma In .Range("J2:J" & .Cells(Rows.Count, "J").End(3).Row).Value
            rngCriteria.Cells(2).Value = firma
            With Sheets("Ayırma")
                .Activate
                .Cells(sat, 1).Value = firma
                .Cells(sat, 1).Font.Bold = True
                .Cells(sat, 1).Font.Size = 14
                sat = sat + 2
                With .Cells(sat, 1).Resize(, 6)
                    .Value = Array("Koli No:", "MİKTAR", "BİRİM", "Cins.", "Ağırlık", "Koli Ölçüleri")
                   rng.Rows(1).Copy
                   .PasteSpecial Paste:=xlPasteFormats
                    rng.advancedFilter 2, rngCriteria, .Cells, False
                End With
                son = .Cells(Rows.Count, 1).End(3).Row
                If .Cells(sat + 1, 1).Value > 1 Then
                    .Range("D1").Value = .Cells(sat + 1, 1).Value - 1
                    .Range("D1").Copy
                    .Range(.Cells(sat + 1, 1), .Cells(son, 1)).PasteSpecial Paste:=xlPasteValues, Operation:=xlSubtract
                    .Range("D1").Value = ""
                End If
                sat = son + 2
                .Range("A:F").Columns.AutoFit
                .Range("A1").Select
            End With
        Next firma
        .Range("J1:J" & .Cells(Rows.Count, "J").End(3).Row).Clear
    End With

End Sub

 

[ismail-34]

Sub advancedFilter()
    '08032024 veyselemre
    Dim rng As Range, firma, rngCriteria As Range, son&, sat&

    Sheets("Ayırma").Cells.Clear

    With Sheets("Veri")
        Set rng = .Range("A1:P" & .Cells(Rows.Count, 1).End(3).Row)
        Set rngCriteria = .Range("J1:J2")
        rngCriteria.Cells(1).Value = "Firma"
        rng.advancedFilter 2, .Range("H1"), .Range("J1"), True
        sat = 1
        For Each firma In .Range("J2:J" & .Cells(Rows.Count, "J").End(3).Row).Value
            rngCriteria.Cells(2).Value = firma
            With Sheets("Ayırma")
                .Activate
                .Cells(sat, 1).Value = firma
                .Cells(sat, 1).Font.Bold = True
                .Cells(sat, 1).Font.Size = 14
                sat = sat + 2
                With .Cells(sat, 1).Resize(, 6)
                    .Value = Array("Koli No:", "MİKTAR", "BİRİM", "Cins.", "Ağırlık", "Koli Ölçüleri")
                   rng.Rows(1).Copy
                   .PasteSpecial Paste:=xlPasteFormats
                    rng.advancedFilter 2, rngCriteria, .Cells, False
                End With
                son = .Cells(Rows.Count, 1).End(3).Row
                If .Cells(sat + 1, 1).Value > 1 Then
                    .Range("D1").Value = .Cells(sat + 1, 1).Value - 1
                    .Range("D1").Copy
                    .Range(.Cells(sat + 1, 1), .Cells(son, 1)).PasteSpecial Paste:=xlPasteValues, Operation:=xlSubtract
                    .Range("D1").Value = ""
                End If
                sat = son + 2
                .Range("A:F").Columns.AutoFit
                .Range("A1").Select
            End With
        Next firma
        .Range("J1:J" & .Cells(Rows.Count, "J").End(3).Row).Clear
    End With

End Sub

VEYsellllllllllll hocammmmm efsaneeeeeeeeeeeeeeeeeeeeeeee olmuşşş yaaaaaaaaaaaaaaaaaaaa ne yaptınız siz mükemmel yaaaaa..
elinize sağlık hocamm resmen sanat eseriiiiiii.. çok çok sağolun değerli hocam..çok uğraşmışınızdır heralde yüreğinize sağlık valla harikasınızzzzzz..

benim tek sorum olcak ben ayırma işini firma isimlerinden alarak değilde J sütunundaki parsiyel diye bir sütunum var ordakilere göre ayırma işlemi yapmak istesem desek .J ye görede bir alternatif sunabilirmisiniz. Örnek linkteki gibi yani bir tablo için konuşuyorum yani. tek fark h den değilde j den veriyi alsın. https://dosya.co/city572aiind/firmaya_göre_koli_ayırma2.xlsm.html

 

[veyselemre]

Sub advancedFilter()
'08032024 veyselemre
    Dim rng As Range, parsiyel, rngCriteria As Range, son&, sat&

    Sheets("Ayırma").Cells.Clear

    With Sheets("Türkçe Çeki List")
        Set rng = .Range("A1:J" & .Cells(Rows.Count, 1).End(3).Row)
        Set rngCriteria = .Range("L1:L2")
        rngCriteria.Cells(1).Value = "Parsiyel"
        rng.advancedFilter 2, .Range("J1"), .Range("L1"), True
        sat = 1
        For Each parsiyel In .Range("L2:L" & .Cells(Rows.Count, "L").End(3).Row).Value
            rngCriteria.Cells(2).Value = parsiyel
            With Sheets("Ayırma")
                .Activate
                .Cells(sat, 1).Value = parsiyel
                .Cells(sat, 1).Font.Bold = True
                .Cells(sat, 1).Font.Size = 14
                sat = sat + 2
                With .Cells(sat, 1).Resize(, 8)
                    .Value = Array("Koli No:", "MİKTAR", "BİRİM", "Cins.", "Ağırlık", "Koli Ölçüleri", "Firma", "Hacimsel Fiyat")
                    rng.Rows(1).Copy
                    .PasteSpecial Paste:=xlPasteFormats
                    rng.advancedFilter 2, rngCriteria, .Cells, False
                End With
                son = .Cells(Rows.Count, 1).End(3).Row
                If .Cells(sat + 1, 1).Value > 1 Then
                    .Range("D1").Value = .Cells(sat + 1, 1).Value - 1
                    .Range("D1").Copy
                    .Range(.Cells(sat + 1, 1), .Cells(son, 1)).PasteSpecial Paste:=xlPasteValues, Operation:=xlSubtract
                    .Range("D1").Value = ""
                End If
                sat = son + 2
                .Range("A:H").Columns.AutoFit
                .Range("A1").Select
            End With
        Next parsiyel
        .Range("L1:L" & .Cells(Rows.Count, "L").End(3).Row).Clear
    End With

End Sub

 

[ismail-34]

Sub advancedFilter()
'08032024 veyselemre
    Dim rng As Range, parsiyel, rngCriteria As Range, son&, sat&

    Sheets("Ayırma").Cells.Clear

    With Sheets("Türkçe Çeki List")
        Set rng = .Range("A1:J" & .Cells(Rows.Count, 1).End(3).Row)
        Set rngCriteria = .Range("L1:L2")
        rngCriteria.Cells(1).Value = "Parsiyel"
        rng.advancedFilter 2, .Range("J1"), .Range("L1"), True
        sat = 1
        For Each parsiyel In .Range("L2:L" & .Cells(Rows.Count, "L").End(3).Row).Value
            rngCriteria.Cells(2).Value = parsiyel
            With Sheets("Ayırma")
                .Activate
                .Cells(sat, 1).Value = parsiyel
                .Cells(sat, 1).Font.Bold = True
                .Cells(sat, 1).Font.Size = 14
                sat = sat + 2
                With .Cells(sat, 1).Resize(, 8)
                    .Value = Array("Koli No:", "MİKTAR", "BİRİM", "Cins.", "Ağırlık", "Koli Ölçüleri", "Firma", "Hacimsel Fiyat")
                    rng.Rows(1).Copy
                    .PasteSpecial Paste:=xlPasteFormats
                    rng.advancedFilter 2, rngCriteria, .Cells, False
                End With
                son = .Cells(Rows.Count, 1).End(3).Row
                If .Cells(sat + 1, 1).Value > 1 Then
                    .Range("D1").Value = .Cells(sat + 1, 1).Value - 1
                    .Range("D1").Copy
                    .Range(.Cells(sat + 1, 1), .Cells(son, 1)).PasteSpecial Paste:=xlPasteValues, Operation:=xlSubtract
                    .Range("D1").Value = ""
                End If
                sat = son + 2
                .Range("A:H").Columns.AutoFit
                .Range("A1").Select
            End With
        Next parsiyel
        .Range("L1:L" & .Cells(Rows.Count, "L").End(3).Row).Clear
    End With

End Sub

eyw çok değerli Veysel hocam harbiden çok özelmişsiniz..canavar gibi çalışıyor tam hayalimdeki gibi sağolun varolun herşey günlünüzce olsun hakkınız helal edin.