![2 Macro Excel de consulta por ejemplo
Francisco 17-01-07
Programación : Ofimática : Curso de macros de MS-Excel 2007
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…
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](https://image.slidesharecdn.com/codigoenvisualbasic-150110203313-conversion-gate01/85/Codigo-en-visual-basic-4-320.jpg)
Codigo en visual basic
- 1. Attribute VB_Name = "Funciones" Option Explicit Public Function EmpiezaPor(ByVal palabra As String, ByVal prefijo As String) As Boolean If Left(UCase(palabra), Len(prefijo)) = UCase(prefijo) Then EmpiezaPor = True Else EmpiezaPor = False End If End Function Public Function Compara(ByVal palabra1 As String, ByVal palabra2 As String) As Boolean If UCase(palabra1) = UCase(palabra2) Then Compara = True Else Compara = False End If End Function Public Function QuitarAcentos(ByVal texto As String) As String Const ACENTOS = "��������������������" Const SIN_ACENTOS = "AEIOU" Dim indice As Integer Dim caracter As String Dim posicion As Integer texto = UCase(texto) For indice = 1 To Len(texto) caracter = Mid(texto, indice, 1) posicion = InStr(ACENTOS, caracter) If posicion > 0 Then posicion = ((posicion - 1) Mod 5) + 1 Mid(texto, indice, 1) = Mid(SIN_ACENTOS, posicion, 1) End If Next QuitarAcentos = texto End Function Public Function Contiene(ByVal contenedor As String, ByVal contenido As String) As Boolean 'No se diferencia may�sculas de min�sculas ni acentos 'Ejemplo: ? contiene("barcelona","ELO") --> true 'Ejemplo: ? contiene("caf�", "e") --> true If InStr(QuitarAcentos(contenedor), QuitarAcentos(contenido)) > 0 Then Contiene = True
- 2. Else Contiene = False End If 'If InStr(UCase(contenedor), UCase(contenido)) > 0 Then ' Contiene = True 'Else ' Contiene = False 'End If End Function Para registrara una listade trabajadores a travésde un botónregistrar WithWorksheets("Nombrede lahoja") fila= 1 Do While True If IsEmpty(.Cells(fila,1)) ThenExitDo fila= fila+ 1 ' Loop .Cells(fila,1) =textbox1.text .Cells(fila,2) =texbox2.text .Cells(fila,3) = textbox3.text .Cells(fila,4) =textbox4.text End With Programandodentrode un comanbutonylimpiandolacajade textoy colocandoenlascabeceras losnombresde lascabeceras WithWorksheets("Hoja2") Worksheets(2).Range("A1").Value ="Apellidos" Worksheets(2).Range("B1").Value ="DNI" Worksheets(2).Range("C1").Value ="Cargo" Worksheets(2).Range("D1").Value="FechaNacimiento" fila= 2 Do While True If IsEmpty(.Cells(fila,1)) ThenExitDo
- 3. fila= fila+ 1 ' Loop .Cells(fila,1) =TextBox1.Text .Cells(fila,2) =TextBox2.Text .Cells(fila,3) = TextBox3.Text .Cells(fila,4) =TextBox4.Text TextBox1.Text=" " TextBox2.Text=" " TextBox3.Text=" " TextBox4.Text=" " End With
- 4. 2 Macro Excel de consulta por ejemplo Francisco 17-01-07 Programación : Ofimática : Curso de macros de MS-Excel 2007 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… 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
- 5. '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