如何復制行並將它們粘貼到給定單元格值的工作表中

Question

我在表中有數據，我在其中比較了兩列 J 和 T。 J 和 T 可以采用的值包括 A2B、APL、BGF、CMA 等（參見代碼）。

如果這些值相等，將第 i 行復制到剛剛選中的單元格名稱的工作表中。

如果這些值不相等，請將第 i 行復制到剛剛選中單元格名稱的工作表中。

示例：比較 J2 和 T2，

假設 J2=T2=BGF 然后復制第 2 行並粘貼到 sheet("BGF")

接下來比較J3和T3

假設J3=BGF和T3=CMA，復制第3行並粘貼到sheet(BGF)和sheet(CMA)

接下來比較J4和T4

假設 J4=Nothing 和 T4=CMA，復制第 4 行並粘貼到工作表 CMA

唯一的其他組合是 Ji 有值而 Ti 為空。

問題：運行此代碼時，如果 J3=BGF 且 T3= nothing（其為空），則該行不會復制到任何工作表。

這是代碼

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

請試試這個代碼。 它與您嘗試的方法略有不同，但我認為它可以完成工作。

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

我認為您將能夠找到自己的方式並進行任何必要的修改。 如果您需要任何幫助，請告訴我。