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/18UalCvxIXuP6imVWZsWLRZPghMqogZp8/view?usp=sharing

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

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

如果非常感谢！！

Fig.1

Fig.2

解决方法

public static List<Path> listOrdered(String path) {
    try (var fileStream = Files.list(Paths.get(path))) {
        return fileStream
            .sorted(new PathComparator())
            .toList();
    } catch (IOException e) {
        e.printStackTrace();
    }
    return Collections.emptyList();
}

,

从一张到几张工作表

• 假设 Source Worksheet 数据是连续的，并从单元格 A1 (CurrentRegion) 开始。
• 调整常量部分和工作簿中的值。

Option Explicit

Sub CopyData()
    
    Const sName As String = "Summary" ' Source Worksheet Name
    Const sdCol As String = "A" ' Destination Worksheet Name Column
    Const sCols As String = "C:E" ' Source Copy Columns
    Const sFirst As Long = 2 ' Source First Row
    
    Const dCol As String = "C" ' Destination First (Paste) Column
    Const dFirst As Long = 7 ' Destination First Row
    Const drOffset As Long = 2 ' Destination Row Offset
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
    
    Dim sLast As Long: sLast = srg.Rows.Count ' Source Last Row
    Dim cCount As Long: cCount = sws.Columns(sCols).Columns.Count
    
    Application.ScreenUpdating = False
    
    Dim srrg As Range ' Source Row Range
    Dim r As Long ' Source Row Counter
    
    Dim dws As Worksheet ' Destination Worksheet
    Dim drrg As Range ' Destination Row Range
    Dim dCell As Range ' Destination Last Cell
    Dim dName As String ' Destination Worksheet Name
    
    For r = sFirst To sLast
        dName = CStr(srg.Columns(sdCol).Rows(r).Value)
        Set dws = Nothing
        On Error Resume Next
        Set dws = wb.Worksheets(dName)
        On Error GoTo 0
        If Not dws Is Nothing Then
            Set dCell = dws.Cells(dws.Rows.Count,dCol).End(xlUp)
            If dCell.Row < dFirst Then
                Set drrg = dws.Cells(dFirst,dCol).Resize(,cCount)
            Else
                Set drrg = dCell.Offset(drOffset).Resize(,cCount)
            End If
            Set srrg = srg.Columns(sCols).Rows(r)
            drrg.Value = srrg.Value
        'Else
            ' Destination Worksheet doesn't exist.
        End If
    Next r
    
    Application.ScreenUpdating = True

End Sub