urutkan baris berdasarkan beberapa skenario

Saya mencoba mengurutkan baris berdasarkan beberapa Nilai. Dalam contoh ini saya mencoba untuk memisahkan "SN Produk" yang cocok (Kolom M) dan "Nama CE" (Kolom L) yang memiliki kode tindakan "Komponen 220 - Diganti" (Kolom N) menjadi satu lembar dan yang tanpa " 220 "ke lembar lain.

Misalnya

• C-666 LC011169 tidak memiliki hadiah "220" dan harus dalam satu lembar
• C-958 LC011169 memiliki "220" dan harus pada lembar sendiri

Saya tahu ini mungkin tampak membingungkan tetapi saya harus mengurutkan ratusan item baris seperti ini setiap hari dan saya sedang berupaya merampingkan proses.

Versi yang disederhanakan akan terlihat seperti gambar di bawah ini (di mana X = Diganti ):

Untuk melangkah lebih jauh, saya mencoba untuk menggabungkan "kode gejala" (Kolom O) setelah operasi pertama selesai. Ini adalah tujuan akhir saya di mana Simbol adalah Gejala :

Saya bereksperimen dengan beberapa VBA untuk menyortir dan menyalin.

Lihat file xlsm yang tertaut di bagian akhir untuk info lebih lanjut.

Jadi yang kita miliki di sini adalah kode VBA yang mengurutkan informasi asli (hanya menyalin, tidak menyentuh daftar asli) menjadi tiga tabel baru.

Apa fungsinya:

• Melewati seluruh tabel asli
• Menyalin setiap baris ke tabel baru, yang sudah ditentukan sebelumnya, dan yang sudah ada pada lembar yang berbeda.

Apa yang tidak dilakukan:

• Periksa duplikat
• Membuat tabel baru

Itu juga termasuk makro untuk menghapus tabel diurutkan. Ini juga bisa digunakan untuk menghapus tabel sebelum mengurutkan kedua kalinya, untuk menghindari duplikat.

Kode Penyortiran (ini kemungkinan besar dapat ditingkatkan, tetapi sudah terlambat):

Sub sortToTables()
    Dim i, iLastRow As Integer
    Dim oLastRow As ListRow
    Dim srcRow As Range
    Dim Replaced As String, Burn As String, Repurpose As String
    iLastRow = Worksheets("Sheet1").ListObjects("Table1").ListRows.Count

    Replaced = "220 - Replaced Component"
    Burn = "C990 - Advised to burn"
    Repurpose = "130 - Repurpose"
    Application.ScreenUpdating = False
    For i = 1 To iLastRow
        If Worksheets("Sheet1").ListObjects("Table1").DataBodyRange(i, 13) = Replaced Then
        Set srcRow = Worksheets("Sheet1").ListObjects("Table1").ListRows(i).Range
        Set oLastRow = Worksheets("220").ListObjects("Table16").ListRows.Add
        srcRow.Copy
        oLastRow.Range.PasteSpecial xlPasteValues

        ElseIf Worksheets("Sheet1").ListObjects("Table1").DataBodyRange(i, 13) = Burn Then
        Set srcRow = Worksheets("Sheet1").ListObjects("Table1").ListRows(i).Range
        Set oLastRow = Worksheets("C990").ListObjects("Table17").ListRows.Add
        srcRow.Copy
        oLastRow.Range.PasteSpecial xlPasteValues

        ElseIf Worksheets("Sheet1").ListObjects("Table1").DataBodyRange(i, 13) = Repurpose Then
        Set srcRow = Worksheets("Sheet1").ListObjects("Table1").ListRows(i).Range
        Set oLastRow = Worksheets("130").ListObjects("Table18").ListRows.Add
        srcRow.Copy
        oLastRow.Range.PasteSpecial xlPasteValues
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Kode untuk membersihkan tabel:

Sub ResetTable()

Dim tbl As ListObject, tbl2 As ListObject, tbl3 As ListObject

Set tbl = Worksheets("220").ListObjects("Table16")
Set tbl2 = Worksheets("C990").ListObjects("Table17")
Set tbl3 = Worksheets("130").ListObjects("Table18")


  If tbl.ListRows.Count >= 1 Then
    tbl.DataBodyRange.Delete
  End If

  If tbl2.ListRows.Count >= 1 Then
    tbl2.DataBodyRange.Delete
  End If

  If tbl3.ListRows.Count >= 1 Then
    tbl3.DataBodyRange.Delete
  End If

End Sub

File: https://drive.google.com/open?id=0B_8icTMsheWfTUV0YjJCaElmTkU

SUNTING

Perbarui kode untuk melakukan apa yang Anda komentari (saya pikir):

Sub sortToTables()
    Dim i, iLastRow As Integer
    Dim oLastRow As ListRow
    Dim srcRow As Range
    Dim Replaced As String, Burn As String, Repurpose As String
    iLastRow = Worksheets("Sheet1").ListObjects("Table1").ListRows.Count

    Application.ScreenUpdating = False
    For i = 1 To iLastRow

        If Worksheets("Sheet1").ListObjects("Table1").DataBodyRange(i, 11) = "C-235" And _
            Worksheets("Sheet1").ListObjects("Table1").DataBodyRange(i, 12) = "LC0001234" And _
            (InStr(1, Worksheets("Sheet1").ListObjects("Table1").DataBodyRange(i, 13), "220") Or _
            InStr(1, Worksheets("Sheet1").ListObjects("Table1").DataBodyRange(i, 13), "221")) Then

            Set srcRow = Worksheets("Sheet1").ListObjects("Table1").ListRows(i).Range
            Set oLastRow = Worksheets("220").ListObjects("Table16").ListRows.Add
            srcRow.Copy
            oLastRow.Range.PasteSpecial xlPasteValues
        Else
            Set srcRow = Worksheets("Sheet1").ListObjects("Table1").ListRows(i).Range
            Set oLastRow = Worksheets("C990").ListObjects("Table17").ListRows.Add
            srcRow.Copy
            oLastRow.Range.PasteSpecial xlPasteValues

        End If
    Next
    Application.ScreenUpdating = True
End Sub

Seperti yang Anda lihat di sini, saya gunakan Instruntuk mendapatkan kecocokan parsial pada string, bukan nilai absolut, karena sel berisi lebih dari sekedar angka.

Jika Anda ingin memeriksa terhadap katakanlah, serial yang berbeda, maka Anda dapat menetapkan nilai itu ke variabel sebagai gantinya, dan masukkan nomor seri yang ingin Anda urutkan dalam kotak teks.

Saya tidak repot-repot mengganti nama seprai, tetapi saya hanya menggunakan dua lembar dalam contoh ini.

Klarifikasi tentang cara menulis pernyataan If - perhatikan tanda kurung di sekitar ATAU:

If ref(x,y) = "string" And ref(x,y2) = "another string" And (ref(x,y3) ="this" Or (ref(x,y3) ="that") Then

   Do stuff

Else '(Or ElseIf)

   Do something else

End If