Как я могу улучшить этот код, чтобы не удалять пустые ячейки, а просто игнорировать их? - PullRequest
0 голосов
/ 10 июля 2019

Когда я использую свой код, я получаю уникальные значения.Но одно из уникальных значений - пустая ячейка, и код, кажется, удаляет эту ячейку при вставке значений.Это портит мои формулы, которые связаны с этими уникальными ценностями.

Мне также интересно, как использовать косвенную функцию в VBA и связать код с двумя конкретными ячейками, чтобы установить определенный диапазон.Я буду благодарен, если кто-то может дать мне хороший ответ на все это.

Я также пытался использовать следующую формулу excel для получения уникальных значений: = IFERROR (INDEX (INDIRECT ($ C $ 14 & "!" & $ C $ 15); MATCH (0; COUNTIF ($B $ 20: B20; INDIRECT ($ C $ 14 & "!" & $ C $ 15) & "") + IF (INDIRECT ($ C $ 14 & "!" & $ C $ 15) = ""; 1; 0); 0)); "")

Эта формула работает, но мой набор данных несколько большой.Поэтому это занимает много времени ...

Private Sub Unique_Click()

Dim xRng As Range
Dim xLastRow As Long
Dim xLastRow2 As Long
Dim I As Integer
On Error Resume Next
Set xRng = Application.InputBox("Please select range:", "Kutools for Excel", Selection.Address, , , , , 8)
If xRng Is Nothing Then Exit Sub
On Error Resume Next
xRng.Copy Range("B21")
xLastRow = xRng.Rows.Count + 1
ActiveSheet.Range("B21:B" & xLastRow).RemoveDuplicates Columns:=1, Header:=xlNo
xLastRow2 = Cells(Rows.Count, "B").End(xlUp).Row
For I = 1 To xLastRow2
  If ActiveSheet.Range("B21:B" & xLastRow2).Cells(I).Value = "" Then
     ActiveSheet.Range("B21:B" & xLastRow2).Cells(I).Delete
  End If
Next

End Sub

1 Ответ

0 голосов
/ 10 июля 2019

Это будет работать:

Private Sub Unique_Click()

Dim xRng As Range
Dim xLastRow As Long
Dim xLastRow2 As Long
Dim I As Integer
On Error Resume Next
Set xRng = Application.InputBox("Please select range:", "Kutools for Excel", Selection.Address, , , , , 8)
If xRng Is Nothing Then Exit Sub
On Error Resume Next
xRng.Copy Range("B21")
xLastRow = xRng.Rows.Count + 1
ActiveSheet.Range("B21:B" & xLastRow).RemoveDuplicates Columns:=1, Header:=xlNo

End Sub

Для петли, которая удаляла пустые ячейки

Попробуйте изменить

Set xRng = Application.InputBox("Please select range:", "Kutools for Excel", Selection.Address, , , , , 8)

до:

Set xRng = Worksheets("Data1").Range("J3:J45999")
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...