VBA每隔一行從范圍和結果輸入中獲取唯一值

我有兩個我想組合的宏，但不知何故它進展不順利......我想要一個宏，它只能從一個范圍內獲取唯一值，并從第 3 行開始每隔一行將它們輸入到另一個作業表中

誰能告訴我應該如何組合這兩個宏？我試圖改變.Font.Size = 20，Application.Transpose(objDict.keys)但沒有奏效。

Sub UniqueValue()
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("F1:F" & objDict.Count) = Application.Transpose(objDict.keys)
End Sub





Sub EverySecond()
Dim EndRow As Long
EndRow = Range("A" & Rows.Count).End(xlUp).Row

    For ColNum = 5 To EndRow Step 2
        Range(Cells(ColNum, 2), Cells(ColNum, 2)).Font.Size = 20
    Next ColNum
End Sub

uj5u.com熱心網友回復：

將唯一值復制到每隔一行

Option Explicit

Sub UniqueEveryOther()

    Const sName As String = "Sheet1"
    Const sFirstCellAddress As String = "A2"
    
    Const dName As String = "Sheet2"
    Const dFirstCellAddress As String = "A2"
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Reference the source range.
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    
    Dim srg As Range
    Dim srCount As Long
    
    With sws.Range(sFirstCellAddress)
        Dim lCell As Range: Set lCell = .Resize(sws.Rows.Count - .Row   1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Sub
        srCount = lCell.Row - .Row   1
        Set srg = .Resize(srCount)
    End With
    
    ' Write the values from the source range to an array.
1
    Dim Data As Variant
    
    If srCount = 1 Then ' one cell
        ReDim Data(1 To 1, 1 To 1): Data(1, 1) = srg.Value
    Else ' multiple cells
        Data = srg.Value
    End If
    
    ' Write the unqiue values from the array to a dictionary.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim Key As Variant
    Dim r As Long
    
    For r = 1 To srCount
        Key = Data(r, 1)
        If Not IsError(Key) Then
            If Len(Key) > 0 Then
                dict(Key) = Empty
            End If
        End If
    Next r
    
    If dict.Count = 0 Then Exit Sub
    
    ' Write the unqiue values from the dictionary to the array.
    
    ReDim Data(1 To 2 * dict.Count - 1, 1 To 1)
    r = -1
    
    For Each Key In dict.Keys
        r = r   2
        Data(r, 1) = Key
    Next Key
    
    ' Write the unique values from the array to the destination range.
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    With dws.Range(dFirstCellAddress)
        .Resize(r).Value = Data
        .Resize(dws.Rows.Count - .Row - r   1).Offset(r).Clear
        '.EntireColumn = AutoFit
    End With
    
    'wb.Save
    
    MsgBox "Uniques populated.", vbInformation

End Sub

標籤：擅长 vba

上一篇：資料透視表-添加總計的百分比

下一篇：當'where-attribute'是日期時，查詢會導致UPDATE語法錯誤