CONVERTIR CODIGO EXCEL 2003 A 2010
Publicado por Anderson (2 intervenciones) el 17/10/2014 04:35:36
Codial Saludo...
Por favor necesito la ayuda, de alguien... un duro que se le mida quizás algo cencillo... Convertir este código vba 2003 a código que lo pueda ejecutar en excel 2010
La macro realiza el siguiente proceso. buscar en documentos word una palabra, y colocar los datos en una hoja de calculo..
Gracias...
Desde popayan / Cauca / Colombia
----------------------------------------------------------------------------------------------------------------
Option Explicit
Sub SearchWordsInDoc()
Dim wDoc As Object
Dim wApp As Object
Dim fs As Variant
Dim lCount&, i&, sText$
Dim sFullName$, lOff&
Set fs = Application.FileSearch
Set wApp = GetWord
If wApp Is Nothing Then GoTo Fin
Application.ScreenUpdating = False
sText = "julio" '//Texto a buscar
Set fs = Application.FileSearch
With fs
.LookIn = "c:windowsescritorio" '//Carpeta de búsqueda
.SearchSubFolders = True
.Filename = "*.doc"
If .Execute(SortBy:=msoSortByLastModified, SortOrder:=msoSortOrderAscending, AlwaysAccurate:=True) > 0 Then
lCount = .FoundFiles.Count
For i = 1 To lCount
sFullName = .FoundFiles(i)
Set wDoc = wApp.Documents.Open(sFullName)
If Not wDoc Is Nothing Then
If FindText(wDoc, sText) Then
[A1].Offset(lOff).Hyperlinks.Add Anchor:=[A1].Offset(lOff), Address:=wDoc.FullName
lOff = lOff + 1
End If
wDoc.Close False
End If
Next
End If
End With
wApp.Quit
Fin:
Application.ScreenUpdating = True
Set fs = Nothing
Set wApp = Nothing
Set wDoc = Nothing
End Sub
Private Function GetWord() As Object
On Error GoTo Create
Set GetWord = GetObject(, "Word.Application")
Exit Function
Create:
Set GetWord = CreateObject("Word.Application")
End Function
Private Function FindText(ByVal Doc As Object, ByVal sText As String) As Boolean
On Error Resume Next
With Doc.Content.Find
.ClearFormatting
If .Execute(FindText:=sText) Then
FindText = True
Else
FindText = False
End If
End With
End Function
-------------------------------------------------------------------------------------------------------------------------------------
Por favor necesito la ayuda, de alguien... un duro que se le mida quizás algo cencillo... Convertir este código vba 2003 a código que lo pueda ejecutar en excel 2010
La macro realiza el siguiente proceso. buscar en documentos word una palabra, y colocar los datos en una hoja de calculo..
Gracias...
Desde popayan / Cauca / Colombia
----------------------------------------------------------------------------------------------------------------
Option Explicit
Sub SearchWordsInDoc()
Dim wDoc As Object
Dim wApp As Object
Dim fs As Variant
Dim lCount&, i&, sText$
Dim sFullName$, lOff&
Set fs = Application.FileSearch
Set wApp = GetWord
If wApp Is Nothing Then GoTo Fin
Application.ScreenUpdating = False
sText = "julio" '//Texto a buscar
Set fs = Application.FileSearch
With fs
.LookIn = "c:windowsescritorio" '//Carpeta de búsqueda
.SearchSubFolders = True
.Filename = "*.doc"
If .Execute(SortBy:=msoSortByLastModified, SortOrder:=msoSortOrderAscending, AlwaysAccurate:=True) > 0 Then
lCount = .FoundFiles.Count
For i = 1 To lCount
sFullName = .FoundFiles(i)
Set wDoc = wApp.Documents.Open(sFullName)
If Not wDoc Is Nothing Then
If FindText(wDoc, sText) Then
[A1].Offset(lOff).Hyperlinks.Add Anchor:=[A1].Offset(lOff), Address:=wDoc.FullName
lOff = lOff + 1
End If
wDoc.Close False
End If
Next
End If
End With
wApp.Quit
Fin:
Application.ScreenUpdating = True
Set fs = Nothing
Set wApp = Nothing
Set wDoc = Nothing
End Sub
Private Function GetWord() As Object
On Error GoTo Create
Set GetWord = GetObject(, "Word.Application")
Exit Function
Create:
Set GetWord = CreateObject("Word.Application")
End Function
Private Function FindText(ByVal Doc As Object, ByVal sText As String) As Boolean
On Error Resume Next
With Doc.Content.Find
.ClearFormatting
If .Execute(FindText:=sText) Then
FindText = True
Else
FindText = False
End If
End With
End Function
-------------------------------------------------------------------------------------------------------------------------------------
Valora esta pregunta
0