Word dosyalarında toplu değişiklik yapma

[osmanmkc]

Merhabalar,

Tarihleri revize etmem gereken bir word kalabalığı mevcut. Dosyaların hepsinin format aynı olup yalnızca belirli bölümlerdeki kelimeler veya sayılar değişecektir. Örneğin tarih ve formu düzenleyen kişi ismi... Bu işlem anladığım kadarıyla makro ile yapılıyor ama nasıl yapıldığını bilmiyorum. Yardımcı olursanız memnun olurum.

İyi çalışmalar.

 

[necati]

Merhaba,
Örnek birkaç word dosyası eklemek yardım almanızı kolaylaştıracaktır.

 

[osmanmkc]

Screenshot-1 hosted at ImgBB

Image Screenshot-1 hosted in ImgBB

ibb.co

Hocam şu üstteki 01.07.2024 ve alttaki TEMMUZ/2023 değiştirilecektir. Her bir dosya için benim seçeceğim tarihler girilsin istiyorum.

 

[necati]

Değiştirilecek yerler:
Aranan değer A sütununda ise
.Text = Cells(i, "A")
sonsat = ws.Range("A1").End(xlDown).Row
Yeni değer B sütununda ise
.Replacement.Text = Cells(i, "B")
Word belgelerinin bulunduğu klasörünüz
Set klasor = obj.GetFolder("D:\OSMAN\DENEME")
Aşağıdaki kodu bir modüle kopyalap Vba'da Tools > References > Microsoft Word x.x Object Library kütüphanesini etkinleştiriniz.

Sub Excelden_Worrde_Bul_Degistir()
Dim wApp As Word.Application
Dim wDoc As Word.Document
Dim obj As Object, klasor As Object
Dim file As String
Dim ws As Worksheet
Dim i As Integer, say As Integer, sonsat As Integer, islemsayisi As Integer

Set ws = ActiveSheet
sonsat = ws.Range("A1").End(xlDown).Row
Set obj = CreateObject("Scripting.FileSystemObject")
Set klasor = obj.GetFolder("D:\OSMAN\DENEME")

file = Dir(klasor & "/" & "*.doc*")
Set wApp = CreateObject("Word.Application")
'wApp.Visible = True
Application.StatusBar = "....İşleminiz yapılıyor...."
Application.ScreenUpdating = False

Do While file <> ""
If Len(file) > 0 And InStr(1, file, "$") = 0 Then
    Set wDoc = wApp.Documents.Open(klasor & "/" & file)
    
    For i = 1 To sonsat
    
        With wDoc.Content.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .MatchWholeWord = True
            .MatchCase = True
            .Text = Cells(i, "A")
            .Replacement.Text = Cells(i, "B")
            If .Execute(Replace:=wdReplaceAll) Then
                say = say + 1
            End If
        End With
    Next i
    
    If say >= 1 Then
        wDoc.Close True
        say = 0
        islemsayisi = islemsayisi + 1
    Else
        wDoc.Close False
    End If
    
file = Dir()
End If
Loop

wApp.Quit
Set wApp = Nothing
Application.ScreenUpdating = True
Application.StatusBar = False
MsgBox islemsayisi & " adet belgede işlem yapıldı", vbInformation
End Sub