當我在作業表 1 中輸入資料時，我已經應用此 vba 代碼將唯一資料從作業表 1 復制到作業表 2 & 此 vba 對我來說非常有用& 在這里我想如何在作業表 2 中的每個條目資料的 E 列中添加重復項計數sheet1 中的重復項
我在 A 列到 D 列 sheet1 中輸入資料
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Sheet1.Range("A2:D" & Range("A" & Rows.Count).End(xlUp).Row).Copy Sheet2.Range("A2:D" & Rows.Count).End(xlUp).Offset(1, 0)
Sheet2.Range("A2", Sheet2.Range("D" & Rows.Count).End(xlUp)).RemoveDuplicates 1
End Sub
uj5u.com熱心網友回復：
作業表更改中的唯一串列
- 當范圍內的單元格
A2:D1048576（前一個A2:D65536）被“修改”時會觸發它（即使你點擊它并按回車鍵，而不是改變值）。 - 它使用一個字典，其鍵保存唯一值，其項保存計數。
- 它將
A:D范圍內的值寫入將被適當修改的陣列（結果寫入頂部，陣列增加一列，計數寫入額外列），并用于將唯一值寫入目標。該dr變數保存結果的行數。 - 它將僅復制值并清除結果下方的范圍。
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ClearError
Const sCols As String = "A:D"
Const sfRow As Long = 2
Const sDupeColumn As Long = 1
Const dfCellAddress As String = "A2"
Dim sfrrg As Range: Set sfrrg = Me.Rows(sfRow).Columns(sCols)
Dim scrg As Range: Set scrg = sfrrg.Resize(Me.Rows.Count - sfrrg.Row 1)
If Intersect(scrg, Target) Is Nothing Then Exit Sub ' no intersection
Dim slRow As Long
slRow = Me.Cells(Me.Rows.Count, sDupeColumn).End(xlUp).Row
If slRow < sfRow Then Exit Sub ' no data
Dim srCount As Long: srCount = slRow - sfRow 1
Dim srg As Range: Set srg = sfrrg.Resize(srCount)
Dim scCount As Long: scCount = srg.Columns.Count
Dim Data As Variant: Data = srg.Value
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim sKey As Variant
Dim sr As Long
Dim dr As Long
Dim c As Long
For sr = 1 To UBound(Data)
sKey = Data(sr, sDupeColumn)
If Not IsError(sKey) Then
If Not IsEmpty(sKey) Then
If dict.Exists(sKey) Then
dict(sKey) = dict(sKey) 1
Else
dr = dr 1
dict(sKey) = 1
For c = 1 To scCount
Data(dr, c) = Data(sr, c)
Next c
End If
End If
End If
Next sr
Dim dcCount As Long: dcCount = scCount 1
ReDim Preserve Data(1 To srCount, 1 To dcCount)
dr = 0
For Each sKey In dict.Keys
dr = dr 1
Data(dr, dcCount) = dict(sKey)
Next sKey
Dim dfCell As Range: Set dfCell = Sheet2.Range(dfCellAddress)
Dim drg As Range: Set drg = dfCell.Resize(dr, dcCount)
Application.EnableEvents = False ' before writing
' Copy
'srg.Copy dfCell ' if you need the formatting
drg.Value = Data
' Clear below.
Dim dcrg As Range
Set dcrg = drg.Resize(Sheet2.Rows.Count - drg.Row - dr 1).Offset(dr)
dcrg.Clear
SafeExit:
If Application.EnableEvents = False Then
Application.EnableEvents = True ' after writing
End If
Exit Sub
ClearError:
Debug.Print "Run-time error'" & Err.Number & "': " & Err.Description
Resume SafeExit
End Sub
uj5u.com熱心網友回復：
我使用矩陣公式
你打字
=SUM(IF($A$1:$A$11=B1;1;0))
然后按 CTRL SHIFT ENTER 將我們的公式轉換為矩陣公式，然后您可以復制到其他單元格
轉載請註明出處，本文鏈接：https://www.uj5u.com/net/386813.html
下一篇：使用單元格值更改圖表系列值