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

问题描述

我是 VBA 新手，所以我不是那么好。这是我第一个问题的后续问题。 VBA Copy and Paste Data with Matching Worksheet Name

我有一个工作簿，其中包含工作表“Summary”（其中合并了所有数据，如图 1 所示）、“8”、“9”、“10”。我想复制“摘要”中的数据，条件是如果列 A 中的单元格包含工作表名称（8,9 或 10），则该单元格的行和列 C 到 E 将粘贴到具有匹配名称的工作表（如图所示）图2）。数据将粘贴在固定范围 C7 到 E7、C14 到 E14、C21 到 E21 等（7 增量）中。但是，如果“摘要”的B列中连续的行具有相等的值，它们将彼此并排粘贴（模糊）。 例如，“摘要”中A列第2至6行的单元格包含“8”，但列B 行 2 和 3 具有相似的值，因此列 C 到 E 的行 2 到 6 将被复制并粘贴到工作表“8”的 C7、C8、C14、C21 等列，如图 2 所示。 链接到我的宏文件：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("*",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

结束子

感谢您的帮助！！！

解决方法

为了比较 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("*",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