Option Explicit
Dim i As Integer
Dim Datos()
Function ConsigaCarpeta(Optional Title As String, Optional RootFolder As Variant) As String
On Error Resume Next
ConsigaCarpeta = CreateObject("Shell.Application").BrowseForFolder(0, Title, 0, RootFolder).Items.Item.Path
End Function
Sub EncuentreDocumentos()
Dim fs
Dim x As Integer
Dim StrDoc As String
Set fs = Application.FileSearch
With fs
On Error GoTo Abort
.LookIn = ConsigaCarpeta(Title:="Seleccione por favor una carpeta", RootFolder:=&H400) ' o &H11
.FileName = "*.doc"
If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) > 0 Then
MsgBox .FoundFiles.Count & " documentos fueron encontrados."
i = 1
ReDim Datos(6, i)
Datos(1, i) = "CP"
Datos(2, i) = "NDT"
Datos(3, i) = "NDC"
Datos(4, i) = "NDV"
Datos(5, i) = "NP"
Datos(6, i) = "NH"
For x = 1 To .FoundFiles.Count
StrDoc = .FoundFiles.Item(x)
Documents.Open FileName:=StrDoc
Call ConsigaDatos
With Documents.Item(StrDoc)
.Saved = True
.Close
End With
Next x
Call EscribaDatos
Else
MsgBox "0 documentos fueron encontrados."
End If
End With
Abort:
End Sub
Private Sub ConsigaDatos()
Dim oDoc As Document
Dim oTbl As Table
Dim oCel As Cell
Dim oRng As Range
For Each oTbl In ActiveDocument.Tables
For Each oCel In oTbl.Range.Cells
If InStr(oCel.Range.Text, "(CP)") > 0 Then
i = i + 1
ReDim Preserve Datos(6, i)
Set oRng = oTbl.Cell(oCel.RowIndex + 1, oCel.ColumnIndex).Range
oRng.End = oRng.End - 1
Datos(1, i) = Replace(Replace(Replace(Trim(oRng.Text), vbCr, ","), vbTab, " "), ",,", ",")
End If
If InStr(oCel.Range.Text, "(NDT)") > 0 Then
Set oRng = oTbl.Cell(oCel.RowIndex + 1, oCel.ColumnIndex).Range
oRng.End = oRng.End - 1
Datos(2, i) = Replace(Replace(Replace(Trim(oRng.Text), vbCr, ","), vbTab, " "), ",,", ",")
End If
If InStr(oCel.Range.Text, "(NDC)") > 0 Then
Set oRng = oTbl.Cell(oCel.RowIndex + 1, oCel.ColumnIndex).Range
oRng.End = oRng.End - 1
Datos(3, i) = Replace(Replace(Replace(Trim(oRng.Text), vbCr, ","), vbTab, " "), ",,", ",")
End If
If InStr(oCel.Range.Text, "(NDV)") > 0 Then
Set oRng = oTbl.Cell(oCel.RowIndex + 1, oCel.ColumnIndex).Range
oRng.End = oRng.End - 1
Datos(4, i) = Replace(Replace(Replace(Trim(oRng.Text), vbCr, ","), vbTab, " "), ",,", ",")
End If
If InStr(oCel.Range.Text, "(NP)") > 0 Then
Set oRng = oTbl.Cell(oCel.RowIndex + 1, oCel.ColumnIndex).Range
oRng.End = oRng.End - 1
Datos(5, i) = Replace(Replace(Replace(Trim(oRng.Text), vbCr, ","), vbTab, " "), ",,", ",")
End If
If InStr(oCel.Range.Text, "(NH)") > 0 Then
Set oRng = oTbl.Cell(oCel.RowIndex + 1, oCel.ColumnIndex).Range
oRng.End = oRng.End - 1
Datos(6, i) = Replace(Replace(Replace(Trim(oRng.Text), vbCr, ","), vbTab, " "), ",,", ",")
End If
Next oCel
Next oTbl
MsgBox "Hello"
End Sub
Private Sub EscribaDatos()
Dim xlApp As Object, xlLibro As Object, xlHoja As Object
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If xlApp Is Nothing Then Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlLibro = xlApp.WorkBooks.Add
Set xlHoja = xlLibro.Sheets(1)
Dim j As Integer
Dim k As Integer
For j = 1 To i
For k = 1 To 6
xlHoja.Cells(j, k) = Datos(k, j)
Next k
Next j
End Sub
