如何复制行并将它们粘贴到给定单元格值的工作表中

Question

I have data in a table, where I compare two columns J and T. The values which J and T can take include A2B, APL, BGF, CMA, among others (see code).

If these values are equal, copy row i into the sheet which has the name of the cells just checked.

If these values are not equal, copy row i into the sheets which have the name of the cells just checked.

Example : Compare J2 and T2,

Suppose J2=T2=BGF then copy row 2 and paste into sheet("BGF")

Next, compare J3 and T3

Suppose J3=BGF and T3=CMA, copy row 3 and paste into sheet(BGF) and sheet(CMA)

Next, compare J4 and T4

Suppose J4=Nothing and T4=CMA, copy row 4 and paste into sheet CMA

the only other combination is where Ji has a value and Ti is empty.

Problem : When running this code, If J3=BGF and T3= nothing (its empty), then the line is not copied to any sheet.

Here's the code

Sub Sortdata()
    'step 1 clear all data
    Sheets("A2B").Cells.ClearContents
    Sheets("APL").Cells.ClearContents
    Sheets("BGF").Cells.ClearContents
    Sheets("CMA").Cells.ClearContents
    Sheets("K Line").Cells.ClearContents
    Sheets("MacAndrews").Cells.ClearContents
    Sheets("Maersk").Cells.ClearContents
    Sheets("OOCL").Cells.ClearContents
    Sheets("OPDR").Cells.ClearContents
    Sheets("Samskip").Cells.ClearContents
    Sheets("Unifeeder").Cells.ClearContents

    Dim i As Long
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim LastRow As Long


    With Worksheets("All Data")
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 2 To LastRow
            If IsEmpty(.Range("J" & i)) Then
                Set ws1 = Nothing
            Else
                Set ws1 = Worksheets(.Range("J" & i).Value)
            End If
            If IsEmpty(.Range("T" & i)) Then
                Set ws2 = Nothing
            Else
                Set ws2 = Worksheets(.Range("T" & i).Value)
            End If

            If ws1 Is Nothing Then
                If Not ws2 Is Nothing Then
                    CopyToWs ws2, .Rows(i)
                End If
            ElseIf ws2 Is Nothing Then
                If Not ws1 Is Nothing Then
                    CopyToWs ws1, .Rows(i)
                End If
            Else
                CopyToWs ws1, Rows(i)
                If ws1.Name <> ws2.Name Then
                    CopyToWs ws2, .Rows(i)
                End If
            End If
        Next
    End With

End Sub

Sub CopyToWs(ws As Worksheet, rng As Range)
    rng.Copy
    ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial xlPasteValuesAndNumberFormats
End Sub

Answer 1

Please try this code. It takes a slightly different approach to what you tried but it gets the job done, I think.

Option Explicit

Sub Sortdata()
    ' Variatus @STO 20 Jan 2020

    Const WsNames As String = "A2B,APL,BGF,CMA,K Line,MacAndrews," & _
                              "Maersk,OOCL,OPDR,Samskip,Unifeeder"

    Dim WsS As Worksheet                ' Source
    Dim Ws As Worksheet
    Dim Rng As Range
    Dim Rt As Long                      ' target row
    Dim LastRow As Long
    Dim J As Long, T As Long
    Dim Tmp As Variant, PrevTmp As Variant
    Dim R As Long, C As Long

    'step 1 clear all data
    Tmp = Split(WsNames, ",")
    For R = LBound(Tmp) To UBound(Tmp)
        On Error Resume Next
        Worksheets(Tmp(R)).Cells.ClearContents
    Next R

    Application.ScreenUpdating = False
    Set WsS = Worksheets("All Data")
    With WsS
        J = .Columns("J").Column
        T = .Columns("T").Column
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For R = 2 To LastRow
            PrevTmp = ""
            For C = J To T Step T - J
                Tmp = .Cells(R, C).Value
                If Len(Tmp) And Tmp <> PrevTmp Then
                    On Error Resume Next
                    Set Ws = Worksheets(Tmp)
                    If Err = 0 Then
                        Set Rng = .Range(.Cells(R, 1), .Cells(R, .Columns.Count).End(xlToLeft))
                        With Ws
                            Rt = Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row + 1, 2)
                            Rng.Copy Destination:=Ws.Cells(Rt, 1)
                        End With
                    End If
                End If
                PrevTmp = Tmp
            Next C
            If R Mod 25 = 0 Then Application.StatusBar = "Currently processing row " & R
        Next R
    End With

    With Application
        .ScreenUpdating = True
        .StatusBar = "Done"
    End With
End Sub

I think you will be able to find your way through it and make any required modifications. Let me know if you require any assistance.