遍历一列并根据单元格值将数据复制到另外两列

Question

如果有任何帮助，我将不胜感激，我会尽力解释，并附上一个示例，我希望完成版本的外观。

我需要遍历 A 列并将 B 列中相邻单元格中的数据复制到 D 列，然后如果 A 列中的下一个国家是同一个国家，则将 B 列中的第二个“实体”复制到 E 列给它。

如果该国家/地区在 A 列中只有 1 个条目，则 B 列中的数据只会复制到 D 列，依此类推。

由于 SJR 的评论而编辑（谢谢）。我尝试了各种解决方案，例如添加索引匹配公式、计数等，但到目前为止没有任何效果，所以我的问题是这是否可以使用 D 和 E 列中的公式来实现，或者添加 VBA 是最好的解决方案，如果是这样，有没有人有什么建议吗？

非常感谢。

Answer 1

复制唯一数据

• 将完整代码复制到标准模块中，例如Module1。
• 调整常量部分中的值。

Option Explicit

Sub CopyUniqueDataValues()
' Needs the 'RefColumn', 'GetUniqueRespectiveValuesInRows'
' and 'GetRange' functions.
    Const ProcTitle As String = "Copy Unique Data Values"
     
    Const sName As String = "Sheet1"
    Const suFirst As String = "A2"
    Const svCol As String = "B"
    
    Const dName As String = "Sheet1"
    Const dFirst As String = "D2"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Create references to the Source Column Ranges and write their
    ' values to the Source Arrays.
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim sufCell As Range: Set sufCell = sws.Range(suFirst)
    Dim surg As Range: Set surg = RefColumn(sufCell)
    If surg Is Nothing Then
        MsgBox "The unique column range is empty.", vbCritical, ProcTitle
        Exit Sub
    End If
    Dim suData As Variant: suData = GetRange(surg)
    Dim svrg As Range: Set svrg = surg.EntireRow.Columns(svCol)
    Dim svData As Variant: svData = GetRange(svrg)
    
    ' Write the resulting values to the Destination Array.
    Dim dData As Variant
    dData = GetUniqueRespectiveValuesInRows(suData, svData)
    If IsEmpty(dData) Then
        MsgBox "No unique data found.", vbCritical, ProcTitle
        Exit Sub
    End If
    
    ' Create a reference to the Destination First Cell.
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dfCell As Range: Set dfCell = dws.Range(dFirst)
    
    ' Clear (e.g. "D2:XFD1048576").
    Dim dcrg As Range: Set dcrg = dfCell.Resize( _
        dws.Rows.Count - dfCell.Row + 1, _
        dws.Columns.Count - dfCell.Column + 1)
    dcrg.Clear
    
    ' Write the values from the Destination Array to the Destination Range.
    Dim drg As Range
    Set drg = dfCell.Resize(UBound(dData, 1), UBound(dData, 2))
    drg.Value = dData
    
    ' Inform.
    MsgBox "Unique data values copied.", vbInformation, ProcTitle
    
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to the one-column range from the first cell
'               of a range ('FirstCell') to the bottom-most non-empty cell
'               of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
    ByVal FirstCell As Range) _
As Range
    If FirstCell Is Nothing Then Exit Function
    
    With FirstCell.Cells(1)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Function
        Set RefColumn = .Resize(lCell.Row - .Row + 1)
    End With

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the values of a range ('rg') in a 2D one-based array.
' Remarks:      If ˙rg` refers to a multi-range, only its first area
'               is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
    ByVal rg As Range) _
As Variant
    If rg Is Nothing Then Exit Function
    
    If rg.Rows.Count + rg.Columns.Count = 2 Then ' one cell
        Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
        GetRange = Data
    Else ' multiple cells
        GetRange = rg.Value
    End If

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the respective values from the second (values) array
'               of each unique value of the first (unique) array in rows
'               of a 2D one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetUniqueRespectiveValuesInRows( _
    ByVal suData As Variant, _
    ByVal svData As Variant) _
As Variant
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim tColl As Collection
    Dim suValue As Variant
    Dim r As Long
    Dim dcCount As Long
    
    For r = 1 To UBound(suData)
        suValue = suData(r, 1)
        If Not IsError(suValue) Then
            If Len(suValue) > 0 Then
                If dict.Exists(suValue) Then
                    Set tColl = dict(suValue) ' existing collection to 'tColl'
                Else
                    Set tColl = New Collection
                End If
                tColl.Add svData(r, 1)
                Set dict(suValue) = tColl
                If tColl.Count > dcCount Then
                    dcCount = tColl.Count
                End If
            End If
        End If
    Next r
     
    If dcCount = 0 Then Exit Function ' only blanks and error values (unlikely)
    
    Dim drCount As Long: drCount = dict.Count
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
    r = 0
    
    Dim Key As Variant
    Dim Item As Variant
    Dim c As Long
    
    For Each Key In dict.Keys
        r = r + 1
        c = 0
        For Each Item In dict(Key)
            c = c + 1
            dData(r, c) = Item
        Next Item
    Next Key

    GetUniqueRespectiveValuesInRows = dData

End Function