ProInf.net

2 Macro Excel de consulta por ejemplo

Francisco 17-01-07
Embudo que filtra datos

La macro extrae datos de una tabla filtrando según el valor de la celda actual. Un ejemplo:

  1. Supongamos que tenemos una tabla de Excel con productos alimenticios clasificados por categoría
  2. En dicha tabla nos colocamos en la celda de la categoría que nos interesa
  3. Ejecutamos la macro (Menú→ Herramientas → Macro → Macros → Ejecutar)
  4. El resultado que obtenemos es un nuevo libro con una copia de la tabla original pero sólo con las filas de la categoría elegida.

Ver imagen de ejemplo…

Código Visual Basic de la macro

Sub MacroConsultaPorEjemplo()
'Extrae los datos según el ejemplo de la celda seleccionada
' y crea un nuevo libro
        
    Dim hojaOrigen As Worksheet, hojaDestino As Worksheet
    Dim colInicio As Long, colFin As Long
    Dim filInicio As Long, filFin As Long
    Dim f As Long, c As Long, ff As Long, cc As Long
    Dim celdaOrigen As Range, celdaEvaluar As Range
    Dim celdaDestino As Variant 'TIENE QUE SER VARIANT POR CULPA DEL MÉTODO COPY
    Dim celdaInicio As Range, celdaFin As Range
    Dim msg As String
    
    'Recordar la hoja principal
    Set hojaOrigen = ActiveSheet
    Set celdaOrigen = ActiveCell
    If celdaOrigen = "" Then Exit Sub
        
    'Averiguar el número de filas y columnas mirango alrededor
    ' de la celda seleccionada
    Selection.End(xlUp).Select: filInicio = ActiveCell.Row
    Selection.End(xlDown).Select: filFin = ActiveCell.Row
    Selection.End(xlToLeft).Select: colInicio = ActiveCell.Column
    Selection.End(xlToRight).Select: colFin = ActiveCell.Column
    If filFin >= 65536 Or colFin >= 256 Then Exit Sub
    
    ''Celda con el contenido del filtro
    'celdaOrigen.Activate
    'Set celdaEvaluar = Cells(filInicio, celdaOrigen.Column)
    'msg = "¿Extraer en un nuevo libro [" & celdaEvaluar & "] '" & celdaOrigen & "' ?"
    'If vbYes <> MsgBox(msg, vbQuestion + vbYesNo) Then
    '    Exit Sub
    'End If
        
    'Crear la nueva hoja en un nuevo libro
    Workbooks.Add
    Set hojaDestino = ActiveSheet
    Call MacroBorrarRestoHojas
    hojaDestino.Name = normalizarNombre(CStr(celdaOrigen))
    
    'Copiar datos fila a fila
    ff = 1
    For f = filInicio To filFin
        'Si es la fila de títulos o está el dato seleccionado
        Set celdaEvaluar = hojaOrigen.Cells(f, celdaOrigen.Column)
        If f = 1 Or celdaEvaluar = celdaOrigen Then
            Set celdaInicio = hojaOrigen.Cells(f, colInicio)
            Set celdaFin = hojaOrigen.Cells(f, colFin)
            Set celdaDestino = hojaDestino.Cells(ff, 1)
            Range(celdaInicio, celdaFin).Copy celdaDestino
            ff = ff + 1
        End If
    Next
      
    'Ajustar
    hojaDestino.Cells.EntireColumn.AutoFit
        
    ''Restablecer
    'hojaOrigen.Activate
    'celdaOrigen.Activate

End Sub

Si te descargas el libro de Excel encontrás otras macros además de la arriba descrita.

Compartir



Añade tu comentario:

(El correo no será publicado)
 

Artículos relacionados:

Ir arriba