copy subfolders, replace text in files and save files in copied subfolders

[pieros]

Hallo,

Ik heb al een flinke VBA code en die doet bijna alles wat ik wil,
alleen worden uit de aangegeven folder ALLE files met "KART*.fmt" uit
de subfolders gekopieerd naar 1 folder. Het is de bedoeling dat alle
originele subfolders worden gekopieerd naar een nieuwe locatie en dat
van daaruit PER subfolder alle files worden doorzocht op de aangegeven
tekststring en dat er tekst in dat file wordt vervangen.
Hier volgt wat ik al heb:

'Filename: Zoek tekst '503' in files.xls - (modTestVBAprogr)
Option Explicit

Sub UpdateFiles()

'Declareren van variabelen
Dim IFileNum As Long
Dim OFileNum As Long
Dim WholeLine As String
Dim i As Long, x As Integer
Dim TestDir As Variant
Dim RowNdx As Integer
Dim ColNdx As Integer
Dim myOutputFolder As String
Dim Regel As Integer

'Foutafhandeling
On Error Resume Next
MkDir myOutputFolder
On Error GoTo 0

'Beginnen in 1e kolom en 1e rij
ColNdx = 1
RowNdx = 1

'Start met zoeken
With Application.FileSearch
.NewSearch
.LookIn = "D:\VBA\Copy of Zoek en vervang tekst '503' in
KART-templates\Approved\Cop00006500\" 'Zoekactie in deze folder
beginnen
' .SearchSubFolders = True 'Ook in subfolders zoeken
.Filename = "*KART*.fmt" 'Zoeken naar alle "KART"-templates


'Gewijzigde files schrijven naar deze locatie
myOutputFolder = "D:\VBA\Copy of Zoek en vervang tekst '503' in
KART-templates\Corrected\Cop00006500\"

If .Execute() > 0 Then 'Ga door als "KART"-template is gevonden
ActiveCell.Range("A1").Select 'Zet cursor in excel in cel
A1
For i = 1 To .FoundFiles.Count 'Herhaal zoveel keer als dat
er "KART"-templates zijn gevonden.

IFileNum = FreeFile
Close #IFileNum
Open .FoundFiles(i) For Input As #IFileNum
'Voorbereiden voor het ophalen van tekstregels

OFileNum = FreeFile
Close #OFileNum
Open myOutputFolder & Dir(.FoundFiles(i)) For Output As
#OFileNum 'Voorbereiden voor het wegschrijven van de gewijzigde
tekstregel

TestDir = .FoundFiles(i)
TestDir = Mid(TestDir, 70, 40)

Regel = 1 'Regelteller op 1 zetten. Beginnen bij regel
1 (kan ook vanaf bv. regel 6)
While Not EOF(IFileNum) 'Zolang het einde van het
tekstfile nog niet is bereikt; ga door
Line Input #IFileNum, WholeLine 'Lees een regel in
If Len(Trim(WholeLine)) > 0 Then 'Staat er tekst in
deze regel ga dan door
If Regel = 11 And Mid(Trim(WholeLine), 13, 3)
<> "503" Then 'Als de 11e regel is bereikt EN er staat geen "503" in
Cells(RowNdx, ColNdx).Value = "De tekst
'MaxHeight = 503' is NIET gevonden in regel " & Regel & " van " &
TestDir & "." 'zet deze tekstregel dan in Excel.
ElseIf Regel = 11 And Mid(Trim(WholeLine),
13, 3) = "503" Then 'Als de 11e regel is bereikt EN er staat WEL "503"
in
Cells(RowNdx, ColNdx).Value = "De tekst
'MaxHeight = 503' is gevonden in regel " & Regel & " van " & TestDir &
"." 'zet deze tekstregel ook dan in Excel.
End If
WholeLine = Replace(WholeLine, " MaxHeight =
503;", _
" MaxHeight = 384; //503 gewijzigd in 384.
dd. 20-10-2005.") 'dd. & Date & ." is ook mogelijk
'Als "MaxHeight = 503;" voorkomt wijzig dit dan
in "MaxHeight = 384;"
Print #OFileNum, WholeLine 'Schrijf deze
gewijzigde regel naar het output file
Else
Print #OFileNum, WholeLine 'Schrijf de
ongewijzigde regel naar het output file

End If
Regel = Regel + 1 ' Regelteller verhogen

Wend
RowNdx = RowNdx + 1 'In excel een regel naar beneden
gaan

Close #IFileNum
Close #OFileNum
Next i
End If
End With

'Schrijf de excel inhoud naar tekstfile
Columns("A:A").Select
' ActiveWorkbook.SaveAs Filename:= _
' "D:\VBA\Copy of Zoek en vervang tekst '503' in
KART-templates\New\Zoek tekst '503' in files.txt" _
' , FileFormat:=xlTextMSDOS
'ActiveWorkbook.Close SaveChanges:=False
End Sub



Kan iemand mij hiermee helpen?

Groeten,
Pieros.