arrays - validacion - Excel celdas claras basadas en el contenido de una lista en otra hoja

validacion de datos en excel ejemplos

Question

Tengo una Hoja de Excel de mil filas y 20 columnas de A1 a T1. Cada celda en ese rango tiene algunos datos, generalmente una o dos palabras. En Sheet2, columna A1, tengo una lista de datos de 1000 valores.

Estoy trabajando en el script de VBA para encontrar palabras de la lista Sheet2 en Sheet1 y borrar los valores de las celdas de las encontradas.

Ahora tengo un script de VBA que funciona solo en la columna A1 de Sheet1 y elimina solo las filas. Aquí está el guión:

Sub DeleteEmails()
Dim rList As Range
Dim rCrit As Range
With Worksheets("Sheet1")
.Range("A1").Insert shift:=xlDown: .Range("A1").Value = "Temp Header"
Set rList = .Range("A1", .Cells(Rows.Count, 1).End(xlUp))
End With
With Worksheets("Sheet2")
.Range("A1").Insert shift:=xlDown: .Range("A1").Value = "Temp Header"
Set rCrit = .Range("A1", .Cells(Rows.Count, 1).End(xlUp))
End With
rList.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=rCrit, Unique:=False
rList.Offset(1).SpecialCells(xlCellTypeVisible).Delete shift:=xlUp
Worksheets("Sheet1").ShowAllData
rList(1).Delete shift:=xlUp: rCrit(1).Delete shift:=xlUp
Set rList = Nothing: Set rCrit = Nothing
End Sub 

¿Alguien podría ayudarme? Necesito los valores borrados, no las filas eliminadas, y esto debería funcionar en todas las columnas de Sheet1, no solo en A1.

Answer 1

No tengo excel para entregar en este momento, así que puede que no sea exactamente 100% exacto en el nombre de las fórmulas, pero creo que esta línea debe cambiar:

rList.Offset(1).SpecialCells(xlCellTypeVisible).Delete shift:=xlUp 

a

rList.Offset(1).ClearContents

una vez que haya configurado rList a su selección deseada. Delete es la razón por la que está eliminando filas y no borrándolas. (1) es la razón por la que estaba haciendo A1 solo en lugar de todo el rango.

EDITAR

El código final con el que probé esto fue (incluye revisar todas las columnas ahora):

Option Explicit
Sub DeleteEmails()
Dim rList As Range
Dim rCrit As Range
Dim rCells As Range
Dim i As Integer
With Worksheets("Sheet2")
.Range("A1").Insert shift:=xlDown
.Range("A1").Value = "Temp Header"
Set rCrit = .Range("A1", .Cells(Rows.Count, 1).End(xlUp))
End With
Set rCells = Sheet1.Range("$A$1:$T$1")
rCells.Insert shift:=xlDown
Set rCells = rCells.Offset(-1)
rCells.Value = "Temp Header"
For i = 1 To rCells.Count
Set rList = Sheet1.Range(rCells(1, i).address, Sheet1.Cells(Rows.Count, i).End(xlUp))
If rList.Count > 1 Then ''if a column is empty as is in my test case, continue to next column
rList.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=rCrit, Unique:=False
rList.Offset(1).ClearContents
Worksheets("Sheet1").ShowAllData
End If
Next i
rCells.Delete shift:=xlUp
rCrit(1).Delete shift:=xlUp
Set rList = Nothing: Set rCrit = Nothing
End Sub

PD: puedo solicitar que no uses '':'' en vba. Es realmente difícil de notar en el IDE predeterminado de vba y me tomó un tiempo entender por qué las cosas estaban sucediendo pero sin sentido.

Answer 2

Aquí hay otro método que usa una matriz al minimizar el tráfico entre las hojas (iteración por rango / celdas) y el código. Este código no usa ningún clear contents . Simplemente tome todo el rango en una matriz, límpielo e ingrese lo que necesita :) con un clic de un botón.

• editado según la solicitud de OP: agregando comentarios y cambiando el código de sus hojas deseadas.

Código:

Option Explicit
Sub matchAndClear()
Dim ws As Worksheet
Dim arrKeys As Variant, arrData As Variant
Dim i As Integer, j As Integer, k As Integer
''-- here we take keys column from Sheet 1 into a 1D array
arrKeys = WorksheetFunction.Transpose(Sheets(1).Range("A2:A11").Value)
''-- here we take to be cleaned-up-range from Sheet 2 into a 2D array
arrData = WorksheetFunction.Transpose(Sheets(2).Range("C2:D6").Value)
''-- here we iterate through each key in keys array searching it in
''-- to-be-cleaned-up array
For i = LBound(arrKeys) To UBound(arrKeys)
For j = LBound(arrData, 2) To UBound(arrData, 2)
''-- when there''s a match we clear up that element
If UCase(Trim(arrData(1, j))) = UCase(Trim(arrKeys(i))) Then
arrData(1, j) = " "
End If
''-- when there''s a match we clear up that element
If UCase(Trim(arrData(2, j))) = UCase(Trim(arrKeys(i))) Then
arrData(2, j) = " "
End If
Next j
Next i
''-- replace old data with new data in the sheet 2 :)
Sheets(2).Range("C2").Offset(0, 0).Resize(UBound(arrData, 2), _
UBound(arrData)) = Application.Transpose(arrData)
End Sub

• Por favor, no que lo que realmente necesita establecer aquí son los rangos:

  1. Rango de llaves
  2. Alcance por limpiar

Salida: (para mostrar el propósito, estoy usando la misma hoja, pero puede cambiar los nombres de las hojas como lo desee.

Edición basada en la solicitud de OP para ejecutar el archivo de OP:

La razón por la que no limpió todas sus columnas es porque en la muestra anterior solo está limpiando dos columnas, ya que tiene 16 columnas. Entonces necesita agregar otro ciclo for para iterar a través de él. No hay mucho rendimiento bajado, pero un poco;) A continuación se muestra una captura de pantalla después de ejecutar la hoja que enviaste. No hay nada que cambiar excepto eso.

Código:

''-- here we iterate through each key in keys array searching it in
''-- to-be-cleaned-up array
For i = LBound(arrKeys) To UBound(arrKeys)
For j = LBound(arrData, 2) To UBound(arrData, 2)
For k = LBound(arrData) To UBound(arrData)
''-- when there''s a match we clear up that element
If UCase(Trim(arrData(k, j))) = UCase(Trim(arrKeys(i))) Then
arrData(k, j) = " "
End If
Next k
Next j
Next i