请求完善VBA宏：按A列唯一值匹配复制C列数据至对应工作表D4起始处

已实现为Loans表A列唯一值创建对应名称的工作表，以下是补充数据复制功能后的完整代码，可将Loans表中A列匹配目标工作表名称的行的C列数据，复制到目标表D4开始的区域：

Sub CreateBranchSheets()
    Dim BranchField As Range
    Dim BranchName As Range
    Dim targetSheet As Worksheet
    Dim DataWSheet As Worksheet
    Dim uniqueBranches As Collection
    Dim branch As Variant
    Dim lastRow As Long
    Dim copyRange As Range
    Dim destRow As Long
    
    Set DataWSheet = Worksheets("Loans")
    Set uniqueBranches = New Collection
    
    ' 收集A列唯一值，避免重复创建工作表
    On Error Resume Next
    For Each BranchName In DataWSheet.Range("A2", DataWSheet.Range("A2").End(xlDown))
        If BranchName.Value <> "" Then
            uniqueBranches.Add BranchName.Value, Key:=CStr(BranchName.Value)
        End If
    Next BranchName
    On Error GoTo 0
    
    Application.ScreenUpdating = False
    
    ' 处理每个唯一分支
    For Each branch In uniqueBranches
        ' 检查工作表是否存在
        On Error Resume Next
        Set targetSheet = ThisWorkbook.Worksheets(branch)
        On Error GoTo 0
        
        ' 不存在则创建并设置表头
        If targetSheet Is Nothing Then
            Set targetSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            targetSheet.Name = branch
            
            ' 设置表头，避免使用Select
            With targetSheet
                .Range("A1").Value = "H"
                .Range("B1").Value = "Account Name"
                .Range("C1").Value = "Amount"
                .Range("F1").Value = "Bill Date"
                .Range("G1").Value = "Comment"
                .Range("H1").Value = "Pay Method"
                .Range("I1").Value = "Post Date"
                
                .Range("A2").Value = "D"
                .Range("B2").Value = "Detail Amount"
                .Range("C2").Value = "Detail Comment"
                .Range("D2").Value = "Unit"
                .Range("E2").Value = "Job"
                .Range("F2").Value = "GLAccount ID"
                .Range("G2").Value = "Property Short Name"
                
                .Range("A3").Value = "H"
                .Range("B3").Value = "21st Mortgage Corporation"
                .Range("C3").FormulaR1C1 = "=VLOOKUP(R3C7,Loans!C1:C12,11,0)+VLOOKUP(R3C7,Loans!C1:C12,12,0)"
                .Range("F3").Value = "Enter Invoice Date"
                .Range("G3").Value = branch
                .Range("H3").Value = "ACH"
                .Range("I3").Formula = "=TODAY()"
            End With
        End If
        
        ' 复制对应C列数据到目标表D4开始的区域
        lastRow = DataWSheet.Cells(DataWSheet.Rows.Count, "A").End(xlUp).Row
        ' 筛选当前分支的数据
        DataWSheet.Range("A1:C" & lastRow).AutoFilter Field:=1, Criteria1:=branch
        
        If DataWSheet.Range("C2:C" & lastRow).SpecialCells(xlCellTypeVisible).Cells.Count > 0 Then
            destRow = targetSheet.Cells(targetSheet.Rows.Count, "D").End(xlUp).Row
            ' 确保从D4开始，若已有数据则接在下方
            destRow = IIf(destRow < 4, 4, destRow + 1)
            DataWSheet.Range("C2:C" & lastRow).SpecialCells(xlCellTypeVisible).Copy _
                Destination:=targetSheet.Range("D" & destRow)
        End If
        
        ' 取消筛选
        DataWSheet.AutoFilterMode = False
        Set targetSheet = Nothing
    Next branch
    
    ' 自动调整所有工作表列宽
    For Each targetSheet In ThisWorkbook.Worksheets
        targetSheet.UsedRange.Columns.AutoFit
    Next targetSheet
    
    Application.ScreenUpdating = True
End Sub

关键优化说明 #

• 用Collection收集A列唯一值，避免重复创建工作表，提升运行效率
• 移除所有Select/ActiveCell操作，直接通过工作表对象操作区域，代码更稳定高效
• 采用自动筛选快速定位匹配数据，精准复制到目标工作表的D4起始位置（若D4已有数据则自动追加到下方）
• 增加空值判断，避免因空单元格导致的运行错误

内容的提问来源于stack exchange，提问作者user1832229