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