Blog Archive
-
▼
2005
(103)
-
▼
março
(9)
- Excel: Utilização da Função SUBTOTAL()
- VBA: Sequencia numerica
- VBA: Definir conteúdo nos Comentários
- Excel: Formatação Condicional
- VBA: Evidenciar células com valores duplicados
- VBE: Associar uma tecla de Função a um procedimento
- VBA: Ler o conteúdo da célula onde se posiciona o ...
- VBA: Personalizar o formato de uma data numa impre...
- VBA: Linha em Rodapé para impressão
-
▼
março
(9)
About Me
Com tecnologia do Blogger.
Seguidores
Estatisticas
2005-03-14
VBA: Evidenciar células com valores duplicados
11:47 da tarde |
Publicada por
JRod - PORTUGAL |
Editar mensagem
Se pretendermos evidenciar as células que contêm valores duplicados (ver exemplo):
pode utilizar-se uma macro, que deverá ser executada depois de "marcar" o Range de células pretendido:
O Código:
Sub ColorDupRows()
Dim rngSrc As Range
Dim NumRows As Integer
Dim ThisRow As Integer
Dim ThatRow As Integer
Dim ThisCol As Integer
Dim RightCol As Integer
Dim J As Integer, K As Integer
Application.ScreenUpdating = False
Set rngSrc = ActiveSheet.Range(ActiveWindow.Selection.Address)
NumRows = rngSrc.Rows.Count
ThisRow = rngSrc.Row
ThatRow = ThisRow + NumRows - 1
ThisCol = rngSrc.Column
RightCol = ThisCol + rngSrc.Columns.Count - 1
For J = ThisRow To (ThatRow - 1)
If Cells(J, ThisCol) > "" Then
For K = (J + 1) To ThatRow
If Cells(J, ThisCol) = Cells(K, ThisCol) Then
With Cells(K, ThisCol).Interior
.ColorIndex = 20
.Pattern = xlSolid
End With
End If
Next K
End If
Next J
Application.ScreenUpdating = True
End Sub
pode utilizar-se uma macro, que deverá ser executada depois de "marcar" o Range de células pretendido:
O Código:
Sub ColorDupRows()
Dim rngSrc As Range
Dim NumRows As Integer
Dim ThisRow As Integer
Dim ThatRow As Integer
Dim ThisCol As Integer
Dim RightCol As Integer
Dim J As Integer, K As Integer
Application.ScreenUpdating = False
Set rngSrc = ActiveSheet.Range(ActiveWindow.Selection.Address)
NumRows = rngSrc.Rows.Count
ThisRow = rngSrc.Row
ThatRow = ThisRow + NumRows - 1
ThisCol = rngSrc.Column
RightCol = ThisCol + rngSrc.Columns.Count - 1
For J = ThisRow To (ThatRow - 1)
If Cells(J, ThisCol) > "" Then
For K = (J + 1) To ThatRow
If Cells(J, ThisCol) = Cells(K, ThisCol) Then
With Cells(K, ThisCol).Interior
.ColorIndex = 20
.Pattern = xlSolid
End With
End If
Next K
End If
Next J
Application.ScreenUpdating = True
End Sub