Fusionar 2 codigos
Hola q tal tengo un problema necesito hacer un buscador en excel pero q me busque datos en todos los libros q existan en una carpeta seleccionada pero q me muestre en q libro hoja y celda se encuentra y tengo 2 codigo uno q hice y otro q me proporcionaron pero quiero fusionarlos para q sea uno solo
Sub BuscarEnLibrosAbiertos()
Dim Libro As Workbook, Hj As Worksheet
Dim C As Range, FirstCell As String
Range("a2:f" & [c65536].End(xlUp).Offset(10).Row).Delete xlShiftUp
Application.ScreenUpdating = False
For Each Libro In Application.Workbooks
If Libro.Name <> ThisWorkbook.Name Then
For Each Hj In Libro.Worksheets
Set C = Hj.Cells.Find(What:=[f1], LookIn:=xlValues, LookAt:=xlPart)
If C Is Nothing Then GoTo ProximaHoja
FirstCell = C.Address
Do
With [a65536].End(xlUp).Offset(1).Resize(1, 3)
.Cells = Array(Libro.Name, Hj.Name, C.Address)
ActiveSheet.Hyperlinks.Add Anchor:=.Cells, Address:="", SubAddress:=C.Address(External:=True)
End With
Set C = Hj.Cells.FindNext(C)
Loop Until FirstCell = C.Address
ProximaHoja:
Next Hj
End If
Next Libro
Set C = Nothing
Range("a2:c" & [c65536].End(xlUp).Offset(10).Row).Font.Size = 12
[a:f].Columns.AutoFit
Application.ScreenUpdating = True
End Sub
Private Sub Botón2_AlHacerClic()
Dim fso As Scripting.FileSystemObject
Dim Folder As Folder
Dim Files As Files
Dim File As File
Dim Extension As String
Dim Arch_Excel As String
Set fso = New Scripting.FileSystemObject
Set Folder = fso.GetFolder("C:\Documents and Settings\israel.perezs\Mis documentos\progra\Ejemplos")
Set Files = Folder.Files
For Each File In Files
Extension = Mid$(File, Len(File) - 3, 4)
If Extension = ".xls" Or Extension = ".xlsx" Then
'Arch_Excel = File
'MsgBox Arch_Excel
End If
Next
Set fso = Nothing
Set Folder = Nothing
Set Files = Nothing
Set File = Nothing
'Dim Excel As Excel.Application
'Set Excel = New Excel.Application
'Excel.Workbooks.Open ("C:\Documents and Settings\israel.perezs\Mis documentos\progra\Ejemplos\lista.xls")
'Excel.Visible = True
End Sub
o si me puedes proporcionaar otra manera de hacerlo te estare muy agradecido
Sub BuscarEnLibrosAbiertos()
Dim Libro As Workbook, Hj As Worksheet
Dim C As Range, FirstCell As String
Range("a2:f" & [c65536].End(xlUp).Offset(10).Row).Delete xlShiftUp
Application.ScreenUpdating = False
For Each Libro In Application.Workbooks
If Libro.Name <> ThisWorkbook.Name Then
For Each Hj In Libro.Worksheets
Set C = Hj.Cells.Find(What:=[f1], LookIn:=xlValues, LookAt:=xlPart)
If C Is Nothing Then GoTo ProximaHoja
FirstCell = C.Address
Do
With [a65536].End(xlUp).Offset(1).Resize(1, 3)
.Cells = Array(Libro.Name, Hj.Name, C.Address)
ActiveSheet.Hyperlinks.Add Anchor:=.Cells, Address:="", SubAddress:=C.Address(External:=True)
End With
Set C = Hj.Cells.FindNext(C)
Loop Until FirstCell = C.Address
ProximaHoja:
Next Hj
End If
Next Libro
Set C = Nothing
Range("a2:c" & [c65536].End(xlUp).Offset(10).Row).Font.Size = 12
[a:f].Columns.AutoFit
Application.ScreenUpdating = True
End Sub
Private Sub Botón2_AlHacerClic()
Dim fso As Scripting.FileSystemObject
Dim Folder As Folder
Dim Files As Files
Dim File As File
Dim Extension As String
Dim Arch_Excel As String
Set fso = New Scripting.FileSystemObject
Set Folder = fso.GetFolder("C:\Documents and Settings\israel.perezs\Mis documentos\progra\Ejemplos")
Set Files = Folder.Files
For Each File In Files
Extension = Mid$(File, Len(File) - 3, 4)
If Extension = ".xls" Or Extension = ".xlsx" Then
'Arch_Excel = File
'MsgBox Arch_Excel
End If
Next
Set fso = Nothing
Set Folder = Nothing
Set Files = Nothing
Set File = Nothing
'Dim Excel As Excel.Application
'Set Excel = New Excel.Application
'Excel.Workbooks.Open ("C:\Documents and Settings\israel.perezs\Mis documentos\progra\Ejemplos\lista.xls")
'Excel.Visible = True
End Sub
o si me puedes proporcionaar otra manera de hacerlo te estare muy agradecido
1 Respuesta
Respuesta de blooddragon
1