Saran Makro - Menempel Baris ke lembar kerja baru, jika sel-sel tertentu membaca "TIDAK"

Saya mau saran menggunakan VBA dan Macro.

Saya akan mencari cara untuk menghubungkan lembar kerja ( lembar kerja 1 hingga 6 ) dengan lembar master ( lembar kerja 7 ).

Jika baris berisi "TIDAK" dalam kolom I (sepanjang lembar kerja 1 hingga 6 ), dapatkah kode menyalin dan menempelkan baris itu ke dalam lembar kerja 7 ?

Lalu jika baris (dalam lembar kerja 1 hingga 6 ) diubah menjadi "IYA NIH" akankah kode lain dapat menghapus baris itu dari lembar kerja 7 ?

Untuk beberapa konteks, lembar kerja 1 hingga 6 adalah daftar pekerjaan dan 'IYA NIH' & amp; 'TIDAK' adalah jika klien telah membayar. Jika 'TIDAK' mereka ditambahkan ke daftar debitur pada lembar kerja 7 . Jika 'IYA NIH' mereka perlu dihapus dari daftar debitur.

Kode ini akan membantu Anda:

Public Sub debtors()
    Dim wkb As Workbook
    Dim wks As Worksheet
    Dim wksdest As Worksheet
    Set wkb = ThisWorkbook
    Set wksdest = wkb.Sheets("Sheet7")
    wksdest.Rows.Clear 'Clear the contents of Sheet7
    destRow = 1 'First row on Sheet7
    For i = 1 To 6 'Loop through Sheets 1 to 6
        newIndex = Right(Str(i), 1)
        thisSheet = "Sheet" + newIndex
        Set wks = wkb.Sheets(thisSheet)
        wks.Activate
        'Selects column I
        Columns("I:I").Select
        'Find a coincidence with the string "NO"
        Set cell = Selection.Find(What:="NO", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
        'If there is a coincidence (is Not Nothing)
        If Not cell Is Nothing Then
            firstRow = cell.Row
            newRow = cell.Row
            'Copy the row and paste on Sheet7
            wks.Rows(newRow).Copy
            wksdest.Rows(destRow).PasteSpecial xlPasteValues
            destRow = destRow + 1
            foundValue = True
            'Find next coincidences in the same sheet
            While foundValue
                Set cell = Selection.FindNext(cell)
                If Not cell Is Nothing Then
                    newRow = cell.Row
                    If newRow <> firstRow Then
                        wks.Rows(newRow).Copy
                        wksdest.Rows(destRow).PasteSpecial xlPasteValues
                        destRow = destRow + 1
                    Else
                        foundValue = False
                    End If
                Else
                    foundValue = False
                End If
            Wend
        End If
    Next i
    wksdest.Activate
End Sub

Buka VBA / Macro dengan ALT + F11 , dibawah Buku Kerja Ini masukkan modul baru dan rekatkan kode di sisi kanan.

Jalankan mengklik segitiga hijau.

Saya memberi komentar pada kode untuk membuat Anda mengerti cara kerjanya.

Anda dapat menjalankannya juga langkah demi langkah dengan mengklik pada baris pertama dan kemudian melalui setiap langkah dengan menekan F8 .