复制具有匹配工作表名称的数据 [英] Copy Data with Matching Worksheet Name

问题描述

我有一个工作簿，其中包含工作表、摘要和工作表(其中所有数据都已合并，如图所示)、8、9、10。

我要从"；摘要&q；复制数据，条件是如果A列中的单元格包含工作表名称(8、9或10)，则该单元格的行和列C到E将粘贴到具有匹配名称的工作表。

粘贴的数据将偏移到第7行，并且每个基准点都将增加一个空格。例如，摘要中A列的第2行到第6行的单元格包含第8行，因此第C行到第E行的第2行到第6行将被复制并粘贴到工作表中。

指向我的宏文件的链接： https://drive.google.com/file/d/18UalCvxIXuP6imVWZsWLRZPghMqogZp8/view?usp=sharing

此代码不会执行偏移量和增量：

Sub Copy_Data()
Application.ScreenUpdating = False
Dim i As Long
Dim j As Double
Sheets("Summary").Activate
Dim lastrow As Long
lastrow = Sheets("Summary").Cells(Rows.Count, "A").End(xlUp).Row
Dim Lastrowa As Long
Dim ans As String

For i = 2 To lastrow
    ans = Cells(i, "A").Value
    Lastrowa = Sheets(ans).Cells(Rows.Count, "C").End(xlUp).Row
    Sheets("Summary").Rows(i).Columns("C:E").Copy
    Sheets(ans).Rows(Lastrowa + 1).Columns("C:E").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Next i
Application.ScreenUpdating = True
End Sub

推荐答案

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
End Sub

这篇关于复制具有匹配工作表名称的数据的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！