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

问题描述：

我是 VBA 新手，所以我不是那么好.我有一个包含工作表摘要"的工作簿(其中所有数据被合并，如图1所示)、8"、9"、10".我想从摘要"中复制数据条件是如果列 A 中的单元格包含工作表名称(8,9 或 10)，则该单元格的行和列 C 到 E 将粘贴到具有匹配名称的工作表(如图 2 所示).粘贴的数据将偏移到第 7 行，每个数据将增加一个空格.例如，摘要"中的 A 列第 2 至 6 行中的单元格包含8"，因此列 C 到 E 的第 2 到 6 行将被复制并粘贴到工作表8".链接到我的宏文件:https://drive.google.com/file/d/18UalCvxIXuP6imVWZsWLRZpghM查看?usp=sharing

Im new to VBA so I am not that good. I have a workbook containing worksheets "Summary" (where all data are consolidated, as shown in Fig.1), "8","9","10". I wanted to copy the data from "Summary" with the condition that if cell in Column A contains the worksheet name (8,9 or 10), that cell's row and Column C to E will pasted to the worksheet with matching name (shown in Fig.2). The pasted data will be offset to row 7, and each datum will be incremented with a space. For example, cells in Column A rows 2 to 6 in "Summary" contains "8", thus Columns C to E rows 2 to 6 will be copied and pasted to sheet "8". Link to my macro file: https://drive.google.com/file/d/18UalCvxIXuP6imVWZsWLRZPghMqogZp8/view?usp=sharing

我有 ff 代码，但它不会做偏移和增量:

I have the ff code but it wont do the offset and increment:

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

如果非常感谢！！

图1

图2

答

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

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

相关推荐