jsoearturh
New Member
- Joined
- Feb 27, 2023
- Messages
- 1
- Office Version
- 365
- Platform
- Windows
i have this code, i was trying to improve i, changing some features, the aim is to somebody can use it just one click, but when the code search for the single or multiple word separated by commas, the new page called Resultados is empty.
Sub BuscadorTuanis()
Dim valoresBuscados As Variant
Dim hojaResultados As Worksheet
Dim filaActual As Long
Dim libroActual As Workbook
Dim hojaActual As Worksheet
Dim rangoActual As Range
Dim valorActual As Variant
Call eliminarFila0
' Aquí abre el textbox para ingresar el valor a buscar
inputValores = Replace(InputBox("Ingrese uno o más valores a buscar, separados por comas"), ", ", ",")
valoresBuscados = Split(inputValores, ",")
If UBound(valoresBuscados) = -1 Then
MsgBox "No se ha ingresado texto a buscar"
Exit Sub
End If
' Verificar si la hoja "Resultados" existe
Dim sheetExists As Boolean
sheetExists = False
For Each hoja In activeWorkBook.Worksheets
If hoja.Name = "Resultados" Then
sheetExists = True
Set hojaResultados = hoja
Exit For
End If
Next hoja
' Si la hoja "Resultados" no existe, se crea
If Not sheetExists Then
Set hojaResultados = activeWorkBook.Sheets.Add(After:=activeWorkBook.Sheets(activeWorkBook.Sheets.Count))
hojaResultados.Name = "Resultados"
End If
' Seleccionar la última fila de la hoja "Resultados"
filaActual = hojaResultados.Cells(hojaResultados.Rows.Count, 1).End(xlUp).Row + 1
' Loop para recorrer: libro activo, hoja activa una a una hasta la última por fila y columna
For Each libroActual In Application.Workbooks
Call quitarFila1
For Each hojaActual In libroActual.Worksheets
Set rangoActual = hojaActual.UsedRange
For Each valorBuscado In valoresBuscados
For Each valorActual In rangoActual
If valorActual = valorBuscado Then
If filaActual = 1 Then
' Copiar la fila de encabezados si es la primera coincidencia
rangoActual.Rows(1).Copy hojaResultados.Cells(filaActual, 1)
filaActual = filaActual + 1
End If
' Copiar la fila encontrada
rangoActual.Rows(valorActual.Row).Copy hojaResultados.Cells(filaActual, 1)
filaActual = filaActual + 1
End If
Next valorActual
Next valorBuscado
Next hojaActual
Next libroActual
If filaActual = 1 Then
' Si no se encontraron coincidencias: muestra mensaje en pantalla.
MsgBox "No se encontraron coincidencias"
Application.DisplayAlerts = False
hojaResultados.Delete
Application.DisplayAlerts = True
Else
Call fittiingColumns
Call EliminarFilasDuplicadasNuevisimo
Call Macro1
Call eliminarfilavacia
End If
End Sub
Sub duplicados()
'Macro agregado para eliminar filas duplicadas: En este punto se hace revision de los duplicados(duplicados: la fila tiene los mismos valores en todas sus celdas en relaci[on a otra) y la eliminacion de los mismos.
Dim ultimaFila As Long
Dim indiceMatch As Long
Dim iCntr As Long
ultimaFila = Range("A65000").End(xlUp).Row
For iCntr = 1 To ultimaFila
If Cells(iCntr, 1) <> "" Then
indiceMatch = WorksheetFunction.Match(Cells(iCntr, 1), Range("A1:A" & ultimaFila), 0)
If iCntr <> indiceMatch Then
Cells(iCntr, 2).EntireRow.Delete xlShiftUp
iCntr = iCntr - 1
End If
End If
Next
End Sub
Sub fittiingColumns()
'
' fittiingColumns Macro
'
'Acomodando o rellenando las columnas al texto
Cells.Select
Cells.EntireColumn.AutoFit
Range("A1").Select
End Sub
Sub comprobarCelda()
For i = 3 To 10
If IsEmpty(Cells(i, 1)) Then
Range("a1").EntireRow.Delete
End If
Next i
End Sub
Sub EliminarFilasDuplicadas()
Dim datos As Variant
Dim filas As Long, columnas As Long
Dim i As Long, j As Long, k As Long
'Obtener los datos de la hoja activa
datos = ActiveSheet.UsedRange.Value
filas = UBound(datos, 1)
columnas = UBound(datos, 2)
'Recorrer las filas de abajo hacia arriba
For i = filas To 2 Step -1
'Comprobar si la fila actual es igual a alguna de las filas superiores
For j = i - 1 To 1 Step -1
If Not IsError(Application.Match(datos(i, 1), datos(j, 1), 0)) Then
'Las dos filas tienen el mismo valor en la primera celda
Dim iguales As Boolean
iguales = True
For k = 2 To columnas
If datos(i, k) <> datos(j, k) Then
'La fila no es completamente igual
iguales = False
Exit For
End If
Next k
If iguales Then
'Eliminar la fila duplicada
Rows(i).Delete
Exit For
End If
End If
Next j
Next i
End Sub
Sub quitarFila1()
Dim rango As Range
Set rango = Range("c1:J1")
If WorksheetFunction.CountA(rango) = 0 Then
Rows(1).Delete
End If
End Sub
Sub eliminarFilasVacias()
Dim ultimaFila As Long
Dim rango As Range
ultimaFila = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Set rango = Range("C1:Q" & ultimaFila)
For i = ultimaFila To 2 Step -1
If WorksheetFunction.CountA(rango.Rows(i - 1)) = 0 Then
Rows(i).Delete
End If
Next i
End Sub
Sub eliminarFilas()
Dim ultimaFila As Long
Dim rango As Range
ultimaFila = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Set rango = Range("C1:L" & ultimaFila)
For i = ultimaFila To 2 Step -1
If WorksheetFunction.CountA(rango.Rows(i - 1)) = 0 Then
Rows(i).Delete
End If
Next i
End Sub
Sub Macro1()
'
' Macro1 Macro
'
'
Cells.Select
Selection.Font.Size = 10
With Selection.Font
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
With Selection
.HorizontalAlignment = xlGeneral
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.RowHeight = 151
Selection.ColumnWidth = 20.27
Cells.EntireRow.AutoFit
Cells.EntireColumn.AutoFit
Range("A2").Select
End Sub
Sub eliminarFila0()
Dim ws As Worksheet
Dim rng As Range
For Each ws In ThisWorkbook.Worksheets
Set rng = ws.Range("c1:i1")
If WorksheetFunction.CountA(rng) = 0 Then
ws.Rows(1).Delete
End If
Next ws
End Sub
Sub EliminarFilasDuplicadasNuevisimo()
Dim rng As Range
Dim i As Long, j As Long, k As Long
Dim numFilas As Long
Dim filaIgual As Boolean
numFilas = 100 ' número máximo de filas a verificar
Set rng = ActiveSheet.Range("A1").Resize(numFilas, ActiveSheet.UsedRange.Columns.Count)
For i = numFilas To 2 Step -1
filaIgual = True
For j = i - 1 To 1 Step -1
For k = 1 To rng.Columns.Count
If rng.Cells(i, k).Value <> rng.Cells(j, k).Value Then
filaIgual = False
Exit For
End If
Next k
If filaIgual Then
rng.Rows(i).Delete
Exit For
End If
filaIgual = True
Next j
Next i
End Sub
Sub eliminarfilavacia()
For fila = 1 To 65536
If Cells(fila, 4).Value = "0" Then
Rows(fila).Delete
End If
Next fila
End Sub
Sub BuscadorTuanis()
Dim valoresBuscados As Variant
Dim hojaResultados As Worksheet
Dim filaActual As Long
Dim libroActual As Workbook
Dim hojaActual As Worksheet
Dim rangoActual As Range
Dim valorActual As Variant
Call eliminarFila0
' Aquí abre el textbox para ingresar el valor a buscar
inputValores = Replace(InputBox("Ingrese uno o más valores a buscar, separados por comas"), ", ", ",")
valoresBuscados = Split(inputValores, ",")
If UBound(valoresBuscados) = -1 Then
MsgBox "No se ha ingresado texto a buscar"
Exit Sub
End If
' Verificar si la hoja "Resultados" existe
Dim sheetExists As Boolean
sheetExists = False
For Each hoja In activeWorkBook.Worksheets
If hoja.Name = "Resultados" Then
sheetExists = True
Set hojaResultados = hoja
Exit For
End If
Next hoja
' Si la hoja "Resultados" no existe, se crea
If Not sheetExists Then
Set hojaResultados = activeWorkBook.Sheets.Add(After:=activeWorkBook.Sheets(activeWorkBook.Sheets.Count))
hojaResultados.Name = "Resultados"
End If
' Seleccionar la última fila de la hoja "Resultados"
filaActual = hojaResultados.Cells(hojaResultados.Rows.Count, 1).End(xlUp).Row + 1
' Loop para recorrer: libro activo, hoja activa una a una hasta la última por fila y columna
For Each libroActual In Application.Workbooks
Call quitarFila1
For Each hojaActual In libroActual.Worksheets
Set rangoActual = hojaActual.UsedRange
For Each valorBuscado In valoresBuscados
For Each valorActual In rangoActual
If valorActual = valorBuscado Then
If filaActual = 1 Then
' Copiar la fila de encabezados si es la primera coincidencia
rangoActual.Rows(1).Copy hojaResultados.Cells(filaActual, 1)
filaActual = filaActual + 1
End If
' Copiar la fila encontrada
rangoActual.Rows(valorActual.Row).Copy hojaResultados.Cells(filaActual, 1)
filaActual = filaActual + 1
End If
Next valorActual
Next valorBuscado
Next hojaActual
Next libroActual
If filaActual = 1 Then
' Si no se encontraron coincidencias: muestra mensaje en pantalla.
MsgBox "No se encontraron coincidencias"
Application.DisplayAlerts = False
hojaResultados.Delete
Application.DisplayAlerts = True
Else
Call fittiingColumns
Call EliminarFilasDuplicadasNuevisimo
Call Macro1
Call eliminarfilavacia
End If
End Sub
Sub duplicados()
'Macro agregado para eliminar filas duplicadas: En este punto se hace revision de los duplicados(duplicados: la fila tiene los mismos valores en todas sus celdas en relaci[on a otra) y la eliminacion de los mismos.
Dim ultimaFila As Long
Dim indiceMatch As Long
Dim iCntr As Long
ultimaFila = Range("A65000").End(xlUp).Row
For iCntr = 1 To ultimaFila
If Cells(iCntr, 1) <> "" Then
indiceMatch = WorksheetFunction.Match(Cells(iCntr, 1), Range("A1:A" & ultimaFila), 0)
If iCntr <> indiceMatch Then
Cells(iCntr, 2).EntireRow.Delete xlShiftUp
iCntr = iCntr - 1
End If
End If
Next
End Sub
Sub fittiingColumns()
'
' fittiingColumns Macro
'
'Acomodando o rellenando las columnas al texto
Cells.Select
Cells.EntireColumn.AutoFit
Range("A1").Select
End Sub
Sub comprobarCelda()
For i = 3 To 10
If IsEmpty(Cells(i, 1)) Then
Range("a1").EntireRow.Delete
End If
Next i
End Sub
Sub EliminarFilasDuplicadas()
Dim datos As Variant
Dim filas As Long, columnas As Long
Dim i As Long, j As Long, k As Long
'Obtener los datos de la hoja activa
datos = ActiveSheet.UsedRange.Value
filas = UBound(datos, 1)
columnas = UBound(datos, 2)
'Recorrer las filas de abajo hacia arriba
For i = filas To 2 Step -1
'Comprobar si la fila actual es igual a alguna de las filas superiores
For j = i - 1 To 1 Step -1
If Not IsError(Application.Match(datos(i, 1), datos(j, 1), 0)) Then
'Las dos filas tienen el mismo valor en la primera celda
Dim iguales As Boolean
iguales = True
For k = 2 To columnas
If datos(i, k) <> datos(j, k) Then
'La fila no es completamente igual
iguales = False
Exit For
End If
Next k
If iguales Then
'Eliminar la fila duplicada
Rows(i).Delete
Exit For
End If
End If
Next j
Next i
End Sub
Sub quitarFila1()
Dim rango As Range
Set rango = Range("c1:J1")
If WorksheetFunction.CountA(rango) = 0 Then
Rows(1).Delete
End If
End Sub
Sub eliminarFilasVacias()
Dim ultimaFila As Long
Dim rango As Range
ultimaFila = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Set rango = Range("C1:Q" & ultimaFila)
For i = ultimaFila To 2 Step -1
If WorksheetFunction.CountA(rango.Rows(i - 1)) = 0 Then
Rows(i).Delete
End If
Next i
End Sub
Sub eliminarFilas()
Dim ultimaFila As Long
Dim rango As Range
ultimaFila = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Set rango = Range("C1:L" & ultimaFila)
For i = ultimaFila To 2 Step -1
If WorksheetFunction.CountA(rango.Rows(i - 1)) = 0 Then
Rows(i).Delete
End If
Next i
End Sub
Sub Macro1()
'
' Macro1 Macro
'
'
Cells.Select
Selection.Font.Size = 10
With Selection.Font
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
With Selection
.HorizontalAlignment = xlGeneral
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.RowHeight = 151
Selection.ColumnWidth = 20.27
Cells.EntireRow.AutoFit
Cells.EntireColumn.AutoFit
Range("A2").Select
End Sub
Sub eliminarFila0()
Dim ws As Worksheet
Dim rng As Range
For Each ws In ThisWorkbook.Worksheets
Set rng = ws.Range("c1:i1")
If WorksheetFunction.CountA(rng) = 0 Then
ws.Rows(1).Delete
End If
Next ws
End Sub
Sub EliminarFilasDuplicadasNuevisimo()
Dim rng As Range
Dim i As Long, j As Long, k As Long
Dim numFilas As Long
Dim filaIgual As Boolean
numFilas = 100 ' número máximo de filas a verificar
Set rng = ActiveSheet.Range("A1").Resize(numFilas, ActiveSheet.UsedRange.Columns.Count)
For i = numFilas To 2 Step -1
filaIgual = True
For j = i - 1 To 1 Step -1
For k = 1 To rng.Columns.Count
If rng.Cells(i, k).Value <> rng.Cells(j, k).Value Then
filaIgual = False
Exit For
End If
Next k
If filaIgual Then
rng.Rows(i).Delete
Exit For
End If
filaIgual = True
Next j
Next i
End Sub
Sub eliminarfilavacia()
For fila = 1 To 65536
If Cells(fila, 4).Value = "0" Then
Rows(fila).Delete
End If
Next fila
End Sub