VBA 使用匹配的 Sheet 名称和多个条件复制和粘贴数据

Question

我是 VBA 的新手，所以我不是很好。这是我第一个问题的后续问题。

我有一个工作簿，其中包含工作sheet的“摘要”（其中合并了所有数据，如图 1 所示）、“8”、“9”、“10”。我想从“摘要”复制数据，条件是如果 A 列中的单元格包含作品sheet 名称（8,9 或 10），则该单元格的行和 C 到 E 列将粘贴到作品sheet 匹配名称（如图 2 所示）。数据将粘贴在固定范围 C7 到 E7、C14 到 E14、C21 到 E21 等（7 增量）。但是，如果“摘要”的B列中连续的行具有相同的值，它们将被粘贴在一起（模糊）。例如，“摘要”中A列第2至6行的单元格包含“8”，但列B 行 2 和 3 具有相似的值，因此 C 列到 E 行 2 到 6 将被复制并粘贴到 sheet "8" 的 C7、C8、C14、C21 等列，如图 2 所示。 Link 到我的宏文件：https://drive.google.com/file/d/18UalCvxIXuP6imVWZsWLRZPghMqogZp8/view?usp=sharing

我有上一个线程的 ff 代码，也许你可以添加或修改一些东西：

Sub Copy_Data()
Dim lastRow As Long, offsetRow As Long, i As Long, No As String, NOSheet As Worksheet, auxRow As Long, summarySheet As Worksheet
Set summarySheet = Worksheets("Summary")
lastRow = summarySheet.Columns("A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
offsetRow = 7
For i = 2 To lastRow
    No = Cells(i, "A")
    Set NOSheet = Worksheets(No)
    auxRow = NOSheet.Columns("C").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    If auxRow > 1 Then auxRow = auxRow + 2
    If auxRow = 1 Then auxRow = offsetRow
    NOSheet.Cells(auxRow, "C") = summarySheet.Cells(i, "C")
    NOSheet.Cells(auxRow, "D") = summarySheet.Cells(i, "D")
    NOSheet.Cells(auxRow, "E") = summarySheet.Cells(i, "E")
Next i

结束子

感谢您的帮助！！！

Answer 1

为了比较 SMR 列，我也将该列复制到工作表 8、9、10 中。我还添加了一些评论。

Sub Copy_Data()
    Dim lastRow As Long, firstRowToCopyData As Long, i As Long, No As Integer, NOSheet As Worksheet, auxRow As Long, summarySheet As Worksheet
    Dim increment As Long, SMR As String, prevSMR As String, firstNO As Integer, lastNO As Integer, k As Long
    
    Set summarySheet = Worksheets("Summary")
    lastRow = summarySheet.Columns("A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row 'last row on Summary sheet
    firstRowToCopyData = 7
    increment = 7
    firstNO = 8
    lastNO = 10
    
    For No = firstNO To lastNO
        k = 0 'we use this varible to count unique SMR values
        For i = 2 To lastRow
            If summarySheet.Cells(i, "A") = No Then
                
                SMR = summarySheet.Cells(i, "B")
                Set NOSheet = Worksheets(CStr(No)) 'assuming sheets 8,9,10,etc already exists
                auxRow = NOSheet.Columns("C").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row 'last row on NOSheet
                If auxRow > 1 Then 'if there is existing data in NOSheet
                    prevSMR = NOSheet.Cells(auxRow, "B")
                    If prevSMR = SMR Then 'if consecutive same SMR value
                        auxRow = auxRow + 1
                    Else
                        k = k + 1
                        auxRow = increment * k 'auxRow=7,14,21...
                    End If
                ElseIf auxRow = 1 Then
                    k = k + 1
                    auxRow = firstRowToCopyData 'same than increment*k because firstRowToCopyData=increment
                End If
                
                NOSheet.Cells(auxRow, "A") = No
                NOSheet.Cells(auxRow, "B") = SMR
                NOSheet.Cells(auxRow, "C") = summarySheet.Cells(i, "C")
                NOSheet.Cells(auxRow, "D") = summarySheet.Cells(i, "D")
                NOSheet.Cells(auxRow, "E") = summarySheet.Cells(i, "E")
            End If
        Next i
    Next No
End Sub

Result

VBA 使用匹配的 Sheet 名称和多个条件复制和粘贴数据

VBA Copy and Paste Data with Matching Sheet Name and Multiple Criteria

excel

vba

cell

worksheet