VBA频率荧光笔function在非常大的Excel表中

在之前的post用户中：LocEngineer设法帮助我编写一个查找函数，该查找函数将在特定类别的列中查找最不频繁的值。

VBA代码在很大程度上适用于某些特定的问题，前面的问题已经得到了充分的回答，所以我认为这需要一个新的职位。

LocEngineer：“神圣的吸烟莫里，蝙蝠侠！如果这真的是你的表…我会说：忘了”UsedRange“。这不能很好的传播…我已经编辑上面的代码更多的硬编码值，请根据你的需要调整值，然后尝试一下，哇，真是太乱了。

这里是代码：

Sub frequenz() Dim col As Range, cel As Range Dim letter As String Dim lookFor As String Dim frequency As Long, totalRows As Long Dim relFrequency As Double Dim RAN As Range RAN = ActiveSheet.Range("A6:FS126") totalRows = 120 For Each col In RAN.Columns '***get column letter*** letter = Split(ActiveSheet.Cells(1, col.Column).Address, "$")(1) '******* For Each cel In col.Cells lookFor = cel.Text frequency = Application.WorksheetFunction.CountIf(Range(letter & "2:" & letter & totalRows), lookFor) relFrequency = frequency / totalRows If relFrequency <= 0.001 Then cel.Interior.Color = ColorConstants.vbYellow End If Next cel Next col End Sub 

代码格式如下：（注意合并的单元格标题的每一列，标题下行到第5行，数据从第5行开始）（另请注意，行是非常充满空列，有时更多比数据。）

最后，我不知道的一个重要变化是如何让它忽略空白单元格。 请指教。 谢谢。

Answer 1

如果要进行的2个调整是1.排除标题，2.空白单元格

1. 排除标题的方式有点dynamic; 这排除了前6行：

---

 With ActiveSheet.UsedRange Set ran = .Offset(6, 0).Resize(.Rows.Count - 6, .Columns.Count) End With 

---

2. 在内部For循环中，在这行之后For Each cel In col.Cells你需要一个IF：

---

 For Each cel In col.Cells If Len(cel.Value2) > 0 Then... 

---

这是修改后的版本（未经testing）：

---

 Option Explicit Sub frequenz() Const MIN_ROW As Long = 6 Const MAX_ROW As Long = 120 Dim col As Range Dim cel As Range Dim rng As Range Dim letter As String Dim lookFor As String Dim frequency As Long With ActiveSheet.UsedRange Set rng = .Offset(MIN_ROW, 0).Resize(MAX_ROW, GetMaxCell.Column) End With For Each col In rng.Columns letter = Split(ActiveSheet.Cells(1, col.Column).Address, "$")(1) For Each cel In col lookFor = cel.Value2 If Len(lookFor) > 0 Then 'process non empty values frequency = WorksheetFunction.CountIf( _ Range(letter & "2:" & letter & MAX_ROW), lookFor) If frequency / MAX_ROW <= 0.001 Then cel.Interior.Color = ColorConstants.vbYellow End If End If Next cel Next col End Sub 

---

。

在确定包含最后一行和一列的值时更新为使用新函数：

---

 Public Function GetMaxCell(Optional ByRef rng As Range = Nothing) As Range 'It returns the last cell of range with data, or A1 if Worksheet is empty Const NONEMPTY As String = "*" Dim lRow As Range, lCol As Range If rng Is Nothing Then Set rng = Application.ActiveWorkbook.ActiveSheet.UsedRange If WorksheetFunction.CountA(rng) = 0 Then Set GetMaxCell = rng.Parent.Cells(1, 1) Else With rng Set lRow = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _ After:=.Cells(1, 1), _ SearchDirection:=xlPrevious, _ SearchOrder:=xlByRows) Set lCol = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _ After:=.Cells(1, 1), _ SearchDirection:=xlPrevious, _ SearchOrder:=xlByColumns) Set GetMaxCell = .Parent.Cells(lRow.Row, lCol.Column) End With End If End Function 

---