Excel에서 VBA 어레이에 고유한 값 입력

Excel에서 VBA 어레이에 고유한 값 입력

Excel 시트에서 범위(행 또는 열)를 가져와 목록/배열을 고유한 값으로 채우는 VBA 코드를 알려 주실 수 있습니까?

table
table
chair
table
stool
stool
stool
chair

매크로가 실행되면 다음과 같은 배열이 생성됩니다.

fur[0]=table
fur[1]=chair
fur[2]=stool

Sub GetUniqueAndCount()

    Dim d As Object, c As Range, k, tmp As String

    Set d = CreateObject("scripting.dictionary")
    For Each c In Selection
        tmp = Trim(c.Value)
        If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
    Next c

    For Each k In d.keys
        Debug.Print k, d(k)
    Next k

End Sub

이 상황에서는 항상 이런 코드를 사용합니다(선택한 딜리미터가 검색 범위에 포함되지 않았는지 확인하세요).

Dim tmp As String
Dim arr() As String

If Not Selection Is Nothing Then
   For Each cell In Selection
      If (cell <> "") And (InStr(tmp, cell) = 0) Then
        tmp = tmp & cell & "|"
      End If
   Next cell
End If

If Len(tmp) > 0 Then tmp = Left(tmp, Len(tmp) - 1)

arr = Split(tmp, "|")

Tim의 딕셔너리 어프로치와 아래의 Jean_Francois의 배리언트 어레이를 조합합니다.

원하는 어레이가 다음 위치에 있습니다.objDict.keys

Sub A_Unique_B()
Dim X
Dim objDict As Object
Dim lngRow As Long

Set objDict = CreateObject("Scripting.Dictionary")
X = Application.Transpose(Range([a1], Cells(Rows.Count, "A").End(xlUp)))

For lngRow = 1 To UBound(X, 1)
    objDict(X(lngRow)) = 1
Next
Range("B1:B" & objDict.Count) = Application.Transpose(objDict.keys)
End Sub

이것은 옛날 방식입니다.

셀을 통한 루프보다 빠르게 실행됩니다(예:For Each cell In Selection직사각형 선택(즉, Ctrl 키를 누르지 않고 랜덤 셀을 여러 개 선택할 수 없음)이 있는 한, 어떠한 경우에도 신뢰성이 높아집니다.

Sub FindUnique()

    Dim varIn As Variant
    Dim varUnique As Variant
    Dim iInCol As Long
    Dim iInRow As Long
    Dim iUnique As Long
    Dim nUnique As Long
    Dim isUnique As Boolean

    varIn = Selection
    ReDim varUnique(1 To UBound(varIn, 1) * UBound(varIn, 2))

    nUnique = 0
    For iInRow = LBound(varIn, 1) To UBound(varIn, 1)
        For iInCol = LBound(varIn, 2) To UBound(varIn, 2)

            isUnique = True
            For iUnique = 1 To nUnique
                If varIn(iInRow, iInCol) = varUnique(iUnique) Then
                    isUnique = False
                    Exit For
                End If
            Next iUnique

            If isUnique = True Then
                nUnique = nUnique + 1
                varUnique(nUnique) = varIn(iInRow, iInCol)
            End If

        Next iInCol
    Next iInRow
    '// varUnique now contains only the unique values. 
    '// Trim off the empty elements:
    ReDim Preserve varUnique(1 To nUnique)
End Sub

MS Excel 365 함수의 이점UNIQUE()

위의 유효한 솔루션을 풍부하게 하기 위해:

Sub ExampleCall()
Dim rng As Range: Set rng = Sheet1.Range("A2:A11")   ' << change to your sheet's Code(Name)
Dim a: a = rng
a = getUniques(a)
arrInfo a
End Sub

Function getUniques(a, Optional ZeroBased As Boolean = True)
Dim tmp: tmp = Application.Transpose(WorksheetFunction.Unique(a))
If ZeroBased Then ReDim Preserve tmp(0 To UBound(tmp) - 1)
getUniques = tmp
End Function

네, 드디어 해냈어요.

Sub CountUniqueRecords()
Dim Array() as variant, UniqueArray() as variant, UniqueNo as Integer,      
Dim i as integer, j as integer, k as integer

Redim UnquiArray(1)

k= Upbound(array)

For i = 1 To k
For j = 1 To UniqueNo + 1
  If Array(i) = UniqueArray(j) Then GoTo Nx
Next j
  UniqueNo = UniqueNo + 1
  ReDim Preserve UniqueArray(UniqueNo + 1)
  UniqueArray(UniqueNo) = Array(i)
Nx:
Next i

MsgBox UniqueNo

End Sub

한 가지 더...

Sub get_unique()
Dim unique_string As String
    lr = Sheets("data").Cells(Sheets("data").Rows.Count, 1).End(xlUp).Row
    Set range1 = Sheets("data").Range("A2:A" & lr)
    For Each cel In range1
       If Not InStr(output, cel.Value) > 0 Then
           unique_string = unique_string & cel.Value & ","
       End If
    Next
End Sub

이 VBA 함수는 범위 또는 2D 어레이 소스를 통과하면 고유한 값의 배열을 반환합니다.

기본적으로는 원본의 첫 번째 열을 처리하지만 선택적으로 다른 열을 선택할 수 있습니다.

링크드인 기사를 썼는데

Function DistinctVals(a, Optional col = 1)
    Dim i&, v: v = a
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v): .Item(v(i, col)) = 1: Next
        DistinctVals = Application.Transpose(.Keys)
    End With
End Function

구식 방법은 내가 가장 좋아하는 선택이었다.감사해요.그리고 그것은 정말 빨랐다.근데 리딤은 안 썼어요.여기에서는 열에 있는 각 고유 "키"에 대한 값을 축적하여 어레이로 이동합니다(종업원의 경우, 값은 하루에 몇 시간씩 작업).그런 다음 각 키와 최종 값을 활성 시트의 총 영역에 넣습니다.여기서 무슨 일이 일어나고 있는지 고통스런 세부사항을 원하는 사람들을 위해 광범위하게 코멘트를 했다.이 코드에 의해서, 제한적인 에러 체크가 행해집니다.

Sub GetActualTotals()
'
' GetActualTotals Macro
'
' This macro accumulates values for each unique employee from the active
' spreadsheet.
'
' History
' October 2016 - Version 1
'
' Invocation
' I created a button labeled "Get Totals" on the Active Sheet that invokes
' this macro.
'
Dim ResourceName As String
Dim TotalHours As Double
Dim TotalPercent As Double
Dim IsUnique As Boolean
Dim FirstRow, LastRow, LastColumn, LastResource, nUnique As Long
Dim CurResource, CurrentRow, i, j As Integer
Dim Resource(1000, 2) As Variant
Dim Rng, r As Range
'
' INITIALIZATIONS
'
' These are index numbers for the Resource array
'
Const RName = 0
Const TotHours = 1
Const TotPercent = 2
'
' Set the maximum number of resources we'll
' process.
'
Const ResourceLimit = 1000
'
' We are counting on there being no unintended data
' in the spreadsheet.
'
' It won't matter if the cells are empty though. It just
' may take longer to run the macro.
' But if there is data where this macro does not expect it,
' assume unpredictable results.
'
' There are some hardcoded values used.
' This macro just happens to expect the names to be in Column C (or 3).
'
' Get the last row in the spreadsheet:
'
LastRow = Cells.Find(What:="*", _
                After:=Range("C1"), _
                LookAt:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row
'
'  Furthermore, this macro banks on the first actual name to be in C6.
'  so if the last row is row 65, the range we'll work with 
'  will evaluate to "C6:C65"
'
FirstRow = 6
Rng = "C" & FirstRow & ":C" & LastRow
Set r = Range(Rng)
'
' Initialize the resource array to be empty (even though we don't really
' need to but I'm old school).  
'
For CurResource = 0 To ResourceLimit
    Resource(CurResource, RName) = ""
    Resource(CurResource, TotHours) = 0
    Resource(CurResource, TotPercent) = 0
Next CurResource
'
' Start the resource counter at 0.  The counter will represent the number of
' unique entries. 
'
 nUnique = 0
'
' LET'S GO
'
' Loop from the first relative row and the last relative row
' to process all the cells in the spreadsheet we are interested in
'
For i = 1 To LastRow - FirstRow
'
' Loop here for all unique entries. For any
' new unique entry, that array element will be
' initialized in the second if statement.
'
    IsUnique = True
    For j = 1 To nUnique
'
' If the current row element has a resource name and is already
' in the resource array, then accumulate the totals for that
' Resource Name. We then have to set IsUnique to false and
' exit the for loop to make sure we don't populate
' a new array element in the next if statement.
'
        If r.Cells(i, 1).Value = Resource(j, RName) Then
            IsUnique = False
            Resource(j, TotHours) = Resource(j, TotHours) + _
            r.Cells(i, 4).Value
            Resource(j, TotPercent) = Resource(j, TotPercent) + _
            r.Cells(i,5).Value
            Exit For
        End If
     Next j
'
' If the resource name is unique then copy the initial
' values we find into the next resource array element.
' I ignore any null cells.   (If the cell has a blank you might
' want to add a Trim to the cell).   Not much error checking for 
' the numerical values either.
'
    If ((IsUnique) And (r.Cells(i, 1).Value <> "")) Then
        nUnique = nUnique + 1
        Resource(nUnique, RName) = r.Cells(i, 1).Value
        Resource(nUnique, TotHours) = Resource(nUnique, TotHours) + _ 
        r.Cells(i, 4).Value
        Resource(nUnique, TotPercent) = Resource(nUnique, TotPercent) + _
        r.Cells(i, 5).Value
    End If                  
Next i
'
' Done processing all rows
'
' (For readability) Set the last resource counter to the last value of
' nUnique.
' Set the current row to the first relative row in the range (r=the range).
'
LastResource = nUnique
CurrentRow = 1
'
' Populate the destination cells with the accumulated values for
' each unique resource name.
'
For CurResource = 1 To LastResource
    r.Cells(CurrentRow, 7).Value = Resource(CurResource, RName)
    r.Cells(CurrentRow, 8).Value = Resource(CurResource, TotHours)
    r.Cells(CurrentRow, 9).Value = Resource(CurResource, TotPercent)
    CurrentRow = CurrentRow + 1
Next CurResource

End Sub

다음 VBA 스크립트는 셀 B5에서 열 B의 마지막 셀까지 $1048576의 모든 고유한 값을 찾습니다.검출되면 어레이(objDict)에 저장됩니다.

Private Const SHT_MASTER = “MASTER”
Private Const SHT_INST_INDEX = “InstrumentIndex”

Sub UniqueList()
    Dim Xyber
    Dim objDict As Object
    Dim lngRow As Long

    Sheets(SHT_MASTER).Activate
    Xyber = Application.Transpose(Sheets(SHT_MASTER).Range([b5], Cells(Rows.count, “B”).End(xlUp)))
    Sheets(SHT_INST_INDEX).Activate
    Set objDict = CreateObject(“Scripting.Dictionary”)
    For lngRow = 1 To UBound(Xyber, 1)
    If Len(Xyber(lngRow)) > 0 Then objDict(Xyber(lngRow)) = 1
    Next
    Sheets(SHT_INST_INDEX).Range(“B1:B” & objDict.count) = Application.Transpose(objDict.keys)
End Sub

이 솔루션의 스크린샷을 사용하여 테스트 및 문서화했습니다.여기 링크를 찾을 수 있습니다.

http://xybernetics.com/techtalk/excelvba-getarrayofuniquevaluesfromspecificcolumn/

변종 데이터 유형을 사용해도 괜찮다면 그림과 같이 고유한 내장 워크시트 함수를 사용할 수 있습니다.

sub unique_results_to_array()
    dim rng_data as Range
    set rng_data = activesheet.range("A1:A10") 'enter the range of data here

    dim my_arr() as Variant
    my_arr = WorksheetFunction.Unique(rng_data)
    
    first_val  = my_arr(1,1)
    second_val = my_arr(2,1)
    third_val = my_arr(3,1)   'etc...    

end sub

카운트 함수에 관심이 없는 경우 카운터 대신 빈 따옴표를 사전 값으로 사용하여 사전 접근 방식을 단순화할 수 있습니다.다음 코드는 데이터를 포함하는 첫 번째 셀을 "A1"이라고 가정합니다.또는 Selection(일반적으로 찡그리는 것은 이해하지만) 또는 시트의 Used Range 속성을 범위로 사용할 수 있습니다.

다음 예시는 모두 원하는 값의 배열에서 빈 값을 생략하는 것을 전제로 하고 있습니다.

다음과 같이 사전 개체를 사용하려면 참조에서 Microsoft Scripting Runtime 라이브러리를 활성화해야 합니다.또한 처음에 dict를 사전이 아닌 새 사전으로 선언하면 나중에 스크립팅 사전과 동일하게 설정하는 단계를 생략할 수 있습니다.또, 사전 키는 일의여야 하며, 이 방법은 특정 사전 키에 대응하는 값을 설정할 때 오류가 발생하지 않기 때문에 일의 키를 가질 위험이 없습니다.

Sub GetUniqueValuesInRange()

    Dim cll     As Range
    Dim rng     As Range
    Dim dict    As New Dictionary
    Dim vArray  As Variant
    
    Set rng = Range("A1").CurrentRegion.Columns(1)
    
    For Each cll In rng.Cells
        If Len(cll.Value) > 0 Then
            dict(cll.Value) = ""
        End If
    Next cll
    
    vArray = dict.Keys
    
End Sub

위의 예는 느린 방법입니다.일반적으로 처음에 값을 배열로 이동하여 모든 계산을 메모리에서 수행할 수 있도록 하는 것이 좋습니다.대규모 데이터 세트에 대해서는, 다음의 처리가 고속화됩니다.

Sub GetUniqueValuesInRange2()

    Dim vFullArray      As Variant
    Dim var             As Variant
    Dim dict            As New Dictionary
    Dim vUniqueArray    As Variant
    
    vFullArray = Range("A1").CurrentRegion.Columns(1).Value
    
    For Each var In vFullArray
        If Len(var) > 0 Then
            dict(var) = ""
        End If
    Next var
    
    vUniqueArray = dict.Keys
    
End Sub

언급URL : https://stackoverflow.com/questions/5890257/populate-unique-values-into-a-vba-array-from-excel