Excel宏开发求助：实现唯一记录关联多区域信息功能

Let's walk through the issues in your current code and fix it to meet your requirements. Your goal is to take each unique record in column F (F2:F6), find all matches in column A, and copy the corresponding region from column B into blank cells next to each unique record.

Key Issues in Your Current Code #

1. .Activate causes errors: If Find doesn't locate a match, calling .Activate on a Nothing object will throw a runtime error. You need to check if the result exists first.
2. Hardcoded destination: You're always pasting to E2 instead of the row corresponding to the current unique record in column F.
3. Only captures the first match: Your code stops at the first occurrence of the unique record in column A, but you need to collect all matching regions.

Corrected Macro Code #

Option Explicit ' Always include this to catch variable declaration errors

Sub SearchArea()
    Dim uniqueCell As Range
    Dim searchResult As Range
    Dim firstMatchAddress As String
    Dim targetCell As Range
    Dim ws As Worksheet
    
    ' Set the worksheet to avoid relying on the active sheet
    Set ws = ThisWorkbook.Worksheets("Sheet1") ' Replace with your actual sheet name
    
    ' Loop through each unique record in F2:F6
    For Each uniqueCell In ws.Range("F2:F6")
        ' Skip empty cells in the unique records range
        If Trim(uniqueCell.Value) <> "" Then
            ' Find the first exact match in column A
            Set searchResult = ws.Columns("A:A").Find(What:=uniqueCell.Value, _
                LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
            
            If Not searchResult Is Nothing Then
                ' Store address of first match to prevent infinite loop
                firstMatchAddress = searchResult.Address
                
                ' Loop through all matching entries
                Do
                    ' Find the first blank cell in the same row, starting from column E
                    Set targetCell = uniqueCell.EntireRow.Cells(1, "E").End(xlToRight).Offset(0, 1)
                    
                    ' If column E is empty, start there instead of jumping to the right
                    If targetCell.Column > ws.Cells(uniqueCell.Row, ws.Columns.Count).End(xlToLeft).Column + 1 Then
                        Set targetCell = uniqueCell.EntireRow.Cells(1, "E")
                    End If
                    
                    ' Copy the region from column B to the target cell
                    ws.Cells(searchResult.Row, "B").Copy Destination:=targetCell
                    
                    ' Find the next match
                    Set searchResult = ws.Columns("A:A").FindNext(searchResult)
                Loop While Not searchResult Is Nothing And searchResult.Address <> firstMatchAddress
            End If
        End If
    Next uniqueCell
End Sub

What Changed & Why #

• Option Explicit: Forces you to declare all variables, which helps catch typos and undefined variables early.
• Worksheet qualification: We explicitly reference the worksheet (ws) so the macro works reliably even if another sheet is active.
• Empty cell check: Skips any blank entries in your unique records range to avoid unnecessary searches.
• Dynamic target cell: Finds the first blank cell in the same row as the unique record (starting at column E), so each matching region is placed in the next available spot.
• Full match vs partial: Changed LookAt:=xlPart to xlWhole to match entire cell values (switch back if you need partial matches, like "Apple" matching "Apple Pie").
• Loop through all matches: Uses FindNext and stores the first match address to ensure we capture every occurrence without looping infinitely.

Usage Tips #

• Replace "Sheet1" with the actual name of your worksheet.
• Test with a small dataset first to ensure it works as expected.
• If you don't need to copy formatting, use targetCell.Value = ws.Cells(searchResult.Row, "B").Value instead of Copy for faster execution.

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