excel - 如果满足三个不同的条件，如何使用 VBA 将数据从一张纸复制到另一张纸？

Question

我想使用 VBA 将满足一些条件的数据从一张表复制到另一张表。

我的目标:
如果符合我的条件，则将工作表 FP 中 E、F 和 G 列中的单元格复制到工作表 MUOR 中的 R、S 和 T 列。

我的条件:

(1) D 列中的单元格和 P 列中的单元格(在 MUOR 表中)必须满足表 FP 的 I 列中的条件。

(2) 如果 D 列中的单元格为空，则跳到 D 列中的下一个单元格。

(3) R、S 或 T 列在粘贴前必须为空。如果不为空，则移至下一个满足条件的单元格。 (请勿替换或复制数据)

其他信息:每天最大批处理编号(D 列)为 3；

面临的问题:
我当前的 VBA 代码无法识别我的条件。它完全忽略了我第 1 天的数据，并复制了第 2 天的所有数据。

请引用所附图片。

表 MUOR


表 FP


我的预期结果


Sample Data here

我当前的代码如下:

Sub LinkData()

Dim y As Long
Dim x As Long
Dim z As Long
Dim lr As Long
Dim arr As Variant
Dim FP As Worksheet
Dim MUOR As Worksheet

Set FP = ThisWorkbook.Sheets("FP")
Set MUOR = ThisWorkbook.Sheets("MUOR")

With FP
   lr = .Cells(.Rows.Count, "A").End(xlUp).Row
    arr = .Range("A1:I" & lr).Value
End With

With MUOR
    For y = 11 To 363
    For z = y - 1 To y + 8
    For x = LBound(arr) To UBound(arr)

    If Cells(11 + y, 4) <> "" And Cells(11 + y, 4) & Cells(10 + z, 16) = arr(x, 9) And IsEmpty(Cells(10 + z, 18)) Then
            .Cells(10 + z, 18) = arr(x, 5)
            .Cells(10 + z, 19) = arr(x, 8)
            .Cells(10 + z, 20) = arr(x, 7)
            Else
            End If
    Next x
    Next z
    Next y


End With

End Sub

任何VBA专家请帮助我。

非常感激!

Answer 1

我认为下面的代码应该给出预期的输出，但不能完全确定，因为上传/共享的工作簿似乎与问题中的屏幕截图不同。

Option Explicit

Private Sub LinkData()

    Dim arrayFromFPSheet() As Variant
    arrayFromFPSheet = GetSourceArray()

    Dim MUOR As Worksheet
    Set MUOR = ThisWorkbook.Worksheets("MUOR")

    Dim rangesToLoopThrough As Range
    Set rangesToLoopThrough = GetDestinationAreas(MUOR)

    With MUOR
        Dim area As Range
        For Each area In rangesToLoopThrough.Areas
            Debug.Assert area.Rows.CountLarge > 1 And area.Rows.CountLarge < 20

            Dim areaFirstRowIndex As Long
            areaFirstRowIndex = area.Rows(1).Row

            Dim areaLastRowIndex As Long
            areaLastRowIndex = area.Rows(area.Rows.Count).Row

            Dim readRowIndex As Long
            For readRowIndex = areaFirstRowIndex To areaLastRowIndex
                If Not IsCellEmpty(.Cells(readRowIndex, "D")) Then

                    Dim batchNumber As String
                    batchNumber = CStr(.Cells(readRowIndex, "D"))

                    Dim writeRowIndex As Long
                    For writeRowIndex = areaFirstRowIndex To areaLastRowIndex
                        If IsCellEmpty(.Cells(writeRowIndex, "R")) And IsCellEmpty(.Cells(writeRowIndex, "S")) And IsCellEmpty(.Cells(writeRowIndex, "T")) Then

                            Dim Grade As String
                            Grade = CStr(.Cells(writeRowIndex, "P"))

                            Dim batchNumberAndGrade As String
                            batchNumberAndGrade = batchNumber & Grade

                            Dim n As Variant
                            n = Application.CountIfs(.Range("P" & areaFirstRowIndex, "P" & writeRowIndex), Grade, .Range("R" & areaFirstRowIndex, "R" & writeRowIndex), batchNumber) + 1
                            Debug.Assert IsNumeric(n)

                            Dim sourceRowIndex As Long
                            sourceRowIndex = GetRowIndexOfNthMatch(n, arrayFromFPSheet, batchNumberAndGrade, 9)

                            If sourceRowIndex > 0 Then
                                .Cells(writeRowIndex, "R") = arrayFromFPSheet(sourceRowIndex, 5)
                                .Cells(writeRowIndex, "S") = arrayFromFPSheet(sourceRowIndex, 8)
                                .Cells(writeRowIndex, "T") = arrayFromFPSheet(sourceRowIndex, 7)
                            End If
                        End If
                    Next writeRowIndex
                End If
            Next readRowIndex
        Next area
    End With
End Sub

Private Function GetDestinationAreas(ByVal someSheet As Worksheet) As Range
    ' Crudely clusters/groups destination sheet into areas (which
    ' should be date-specific, although this function will not check/verify
    ' output).
    Const START_ROW_INDEX As Long = 10

    Dim outputRange As Range
    Set outputRange = someSheet.Range("C" & START_ROW_INDEX, "C" & someSheet.Rows.Count)

    On Error Resume Next
    Set outputRange = outputRange.SpecialCells(xlCellTypeConstants) ' Will raise error if no constants found.
    On Error GoTo 0
    Debug.Assert Not (outputRange Is Nothing)

    Set GetDestinationAreas = outputRange
End Function

Private Function GetSourceArray() As Variant
    With ThisWorkbook.Worksheets("FP")
        Dim lastRow As Long
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        Dim outputArray() As Variant
        outputArray = .Range("A1:I" & lastRow).Value
    End With
    GetSourceArray = outputArray
End Function

Private Function IsCellEmpty(ByVal someCell As Range) As Boolean
    ' https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/isempty-function
    ' "IsEmpty only returns meaningful information for variants."
    ' So using below function instead.
    IsCellEmpty = Len(CStr(someCell.Value)) = 0
End Function

Private Function GetRowIndexOfNthMatch(ByVal n As Long, ByRef someArray() As Variant, ByVal someText As String, ByVal targetColumn As Long) As Long
    ' Returns a 1-based row index of the nth occurrence of text value
    ' in target column of array or 0 if unsuccessful.
    Debug.Assert n > 0

    Dim rowIndex As Long
    For rowIndex = LBound(someArray, 1) To UBound(someArray, 1)
        If someArray(rowIndex, targetColumn) = someText Then
            Dim matchCount As Long
            matchCount = matchCount + 1

            If matchCount = n Then
                GetRowIndexOfNthMatch = rowIndex
                Exit Function
            End If
        End If
    Next rowIndex
End Function

感谢您在问题中提供的所有信息。这样更容易回答。