Блог

Я был бы признателен за любую помощь, которую я сделаю все возможное, чтобы объяснить, и я приложил пример того, как я хотел бы, чтобы готовая версия выглядела.

Мне нужно пройти по столбцу A и скопировать данные в соседнюю ячейку в столбце B в столбец D, затем, если следующая страна в столбце A является той же страной, скопировать 2-ю «Сущность» в столбце B в столбец E рядом с ней.

Если в стране есть только 1 запись в столбце A, то данные в столбце B будут скопированы только в столбец D и так далее.

Отредактировано из-за комментария SJR(спасибо). Я пробовал различные решения, такие как добавление формул соответствия индексов, графов и т. Д., Но до сих пор ничего не работало, Поэтому мой вопрос заключается в том, можно ли этого достичь с помощью формулы в столбцах D и E или добавление VBA будет лучшим решением, и если да, у кого-нибудь есть какие-либо предложения?

Заранее большое спасибо.

Копирование Уникальных Данных

• Скопируйте полный код в стандартный модуль, например 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