Question

我一直在研究一种解决方案，该解决方案可以算出一栏唯一值的距离，如果你们能帮助我，我会非常感激，因为我是编程的新手。

我已经完成了从一张纸到另一张纸的复制粘贴，（（A列是电缆列表，B列是该电缆所需的距离。）然后，我清洗Blank Cells而不是0。在那之后，我已在第3列中消除了0。

在第三列中，我开发了一些代码来为我提供列1中存在的唯一值列表。

我的下一个目标是创建一个唯一值（第3列）与第1列进行比较的计数。如果电缆X在第1列中出现多次，则其距离必须在第1行中增加第4列（计数列）。如果没有，它将被添加到第二行，等等。。。等等。

你们能帮我提供代码吗？我要留下我的代码版本。谢谢！

Private Sub CommandButton4_Click()
Dim LastRow As Long, LastRow2 As Long, LastRow3 As Long
Dim sh As Worksheet, rng As Range
Dim a As Range, b As Range, c As Range
Dim x As Integer, contagem As String

For j = 1 To 1432

'limpar células em branco acrescentando 0 às células sem valor na distância   
Next j
  For Each a In Range("A1:A1432").Cells
     If a.Value = "" Then a.Value = 0
  Next a
  For Each b In Range("B1:B1432").Cells
    If b.Value = "" Then b.Value = 0
    Next b
Range("B1:B1432").Select
For Each c In Selection
    If Not c.HasFormula And Not IsEmpty(c) Then c = Val(c)
Next c

'Eliminar o valor 0 da coluna D

Set sh = Folha4
LastRow = sh.Range("d" & Rows.Count).End(xlUp).Row
LastRow2 = sh.Range("b" & Rows.Count).End(xlUp).Row
LastRow3 = sh.Range("a" & Rows.Count).End(xlUp).Row

For i = 1 To LastRow
    If Cells(i, 4).Value <> "0" Then
        Cells(counter + 1, 4).Value = Cells(i, 4).Value
        counter = counter + 1
    End If
Next i

With ActiveSheet
    .Range("D1", .Range("D1").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
End With

Set items = CreateObject("Scripting.Dictionary")

    For i = 1 To LastRow3
        If Not items.exists(sh.Range("A" & i).Value) Then
        items.Add sh.Range("A" & i).Value, i
            For x = 1 To LastRow
                If sh.Range("d" & x).Value = sh.Range("A" & i).Value Then
                sh.Range("e" & x).Value = sh.Range("b" & x)
                x = sh.Range("d" & Rows.Count).End(xlUp).Row
                End If
            Next x
        Else
            For x = 1 To LastRow
                If sh.Range("d" & x).Value = sh.Range("A" & i).Value Then
                sh.Range("e" & x).Value = sh.Range("b" & x).Value + items(sh.Range("a" & i).Value)
                End If
            Next x
        End If
    Next i
End Sub

VBA for Excel：与另一列重复项相比，计数唯一元素

0 个答案: