Dynamic array and find dates in Word 1

[2781]

Hi,

A set of documents has normal text interspersed with line paragraphs commencing with a date, tab, number, tab, number. I want to retrieve these latter lines, and copy them to an array if the date is later than a pre-set date.

So far, I have done the piece of code given below, which works except that:

- First, I would prefer that the code first searches for a date instead of any number.

- Secondly, I want to copy these lines to a dynamic array, and this does not seem to work.

' Zoek een prestatie lijn vanaf het begin van het bestand

Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
With Selection.Find
.Text = "^#^t^#^t^#^#^t^#^#^t^#"
.Forward = True
.Execute

' Adapt the dynamic array strPrestaties index and fill the
' array as long as the string prestaties is found.

While .Found

.Parent.Expand Unit:=wdParagraph
strPrestatie = Selection.Text
strPrestaties(x) = strPrestatie
x = x + 1
Selection.EndKey Unit:=wdLine
Selection.TypeParagraph
.Execute

Wend

Documents(strBestand).Close SaveChanges:=wdDoNotSaveChanges

 

[dsi]

For a dynamic array, look into Redim Preserve.

'Written for Option Base 1

Dim MyArray() As String
Dim iIdx As Long

ReDim MyArray(1)
iIdx = 0

Do While (Your Loop)
    iIdx = iIdx + 1
    ReDim Preserve MyArray(iIdx)
    MyArray(iIdx) = CurrentValue
Loop

For iIdx = 1 to Ubound(MyArray)
    MsgBox MyArray(iIdx)
Next iIdx
[code]
As far as searching Word documents, you could scan each word or sentance for the value you are looking for.
[code]
'SEARCH BY WORDS
Dim wd As Word
For Each wd In ActiveDocument.Words
    If IsDate(wd) = True Then
        'Check it and add to array
    End If
Next wd

'SEARCH BY SENTANCES
Dim v1 As Variant
Dim sSent As String
Selection.HomeKey Unit:=wdStory
For Each v1 In ActiveDocument.Sentences
    sSent = v1.Text
    If InStr(1, sSent, "Your Search Characters") > 0 Then
        'Strip, check and store values
    End If
Next v1

Hope this helps...

 

[2781]

I wish to thank you very much. I am a beginner, and this type of support is really great.

I still seem to have a small problem: when I try to run the macro, it stops on "wd As Word", and says: expected user-defined variable, not project.

Secondly, the macro becomes lenghty, to the detriment of the legibility. I have tried to create modules, but seemingly, I do not succeed. Maybe, could you help me in this as well. As already mentioned, I am extremely grateful for your assistance.

The purpose of the macro is to copy all strings looking like "^#^t^#^t^#^#^t^#^#^t^#" (called strPrestatie) out of which the first number is a date later than a predefined date, to an excel file, where I parse the numbers. Ideally, the parsing could be done before exporting to the excel file.

Sub Medar()
'
' Medar Macro
' Macro recorded 15-3-02 by LETIMA

' Create the variable strBestand for the various documents
' Create the variabele strPrestatie to read a "prestatie" line
' Create a dynamic array strPrestaties and declare an array index iIndex

Dim strBestand As String, strPrestatie As String, strPrestaties(), strSentence As String
Dim iIndex As Integer
Dim wd As Word

' initialise strPrestaties() array and index

ReDim strPrestaties(1)
iIndex = 0

' Find Word documents in the directory "Medar"

Set fs = Application.FileSearch
With fs
.LookIn = "C:\Documents and Settings\Administrator\Mijn documenten\Medar"
.FileName = "*.doc"
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) > 0 Then

' Open the files sequentially

For i = 1 To .FoundFiles.Count
strBestand = .FoundFiles(i)

Documents.Open FileName:=strBestand, ReadOnly:=True

' Find a date from the beginning of the file

Selection.HomeKey Unit:=wdStory
For Each wd In ActiveDocument.Words
If IsDate(wd) = True Then
If wd > "01-01-20002" Then

' Ensure that the date belongs to a sentence with a given code structure

Selection.Parent.Expand Unit:=wdParagraph
strSentence = Selection.Text
If InStr(1, strSentence, "^#^t^#^t^#^#^t^#^#^t^#&quot > 0 Then

' Adapt the dynamic array strPrestaties index
' and fill it as long "prestaties" are found

iIndex = iIndex + 1
ReDim Preserve strPrestaties(iIndex)
strPrestatie = Selection.Text
strPrestaties(iIndex) = strPrestatie

For iIndex = 1 To UBound(strPrestaties())
MsgBox strPrestaties(iIndex)
Next iIndex
End If
End If
End If
Next wd

Documents(strBestand).Close SaveChanges:=wdDoNotSaveChanges

End With
Next i

Else
MsgBox "There were no files found."
End If

' We can now transfer the filled array to Excel
' But first, we create an "instance of excel"

Dim ExcelSheet As Object
Set ExcelSheet = CreateObject("Excel.Sheet&quot
With ExcelSheet.Application

.Visible = True ' We visualise the excel sheet

' THen we fill the Excel rows with the array elements

For y = 0 To 40
.Cells(y + 1, 1) = strPrestaties
Next

' We save the workbook as Medar, exit ExcelSheet, en erase the ExcelSheet object

.ActiveWorkbook.SaveAs "C:\Documents and Settings\Administrator\Mijn documenten\Medar\Medar.XLS"
.Quit
End With

Set ExcelSheet = Nothing


End With
End Sub

 

[dsi]

Sorry, I was thinking that was an object similar to Ssentances. That is the Word application object. I guess that the search by word will not work. I will look into it when I get a chance.