Makroda Replace Hatası Hk..

[1903emre34@gmail.com]

Merhaba,

Word sayfalarında üst bilgi kısmına yer alan E1/ yanına sıra numarası vermeye çalışıyorum, aşağıdaki satır hata (kalın) verdi., word dosyasını ekledim, nasıl düzenlerim.

Private Sub CommandButton1_Click()
[A:E] = Empty
Set ds = CreateObject("Scripting.FileSystemObject")

Set f = ds.GetFolder(ThisWorkbook.Path & "\KL")
Set dc = f.Files
For Each dosya In dc
If ds.GetExtensionName(dosya) Like "doc*" Then
Set s = CreateObject("Word.Application")
Set y = s.Documents.Open(f & "\" & dosya.Name)
s.Visible = True
y.PageSetup.DifferentFirstPageHeaderFooter = True
Set u = y.Sections(1).Headers(2).Range.tables(1)
n = n + 1
Cells(n, 1) = CDate(Replace(Replace(Trim(u.Rows(2).Cells(6).Range.Text), Chr(13), ""), Chr(7), ""))
Cells(n, 2) = Replace(Trim(Replace(Replace(u.Rows(1).Cells(7).Range.Text, Chr(13), ""), Chr(7), "")), " ", "")
If Cells(n, 2) = "" Then Cells(n, 2) = Replace(Replace(Trim(Replace(u.Rows(2).Cells(9).Range.Text, Chr(13), "")), Chr(7), ""), " ", "")
Cells(n, 3).Value = dosya.Name
y.Close savechanges:=False
s.Quit
End If
Next
a = Cells(Rows.Count, 1).End(xlUp).Row
Range("A1:C" & a).Sort Key1:=Cells(1, 1), Order1:=xlAscending

For w = 1 To a
Set s = CreateObject("Word.Application")
Set y = s.Documents.Open(f & "\" & Cells(w, "C").Text)
s.Visible = True
ff = ff + 1: r = r + 1
Cells(w, "E") = Cells(1, "F") & Format(ff, "0##")
ff = ff + s.ActiveDocument.ActiveWindow.ActivePane.Pages.Count - 1
y.PageSetup.DifferentFirstPageHeaderFooter = True
Set u = y.Sections(1).Headers(2).Range.tables(1)
If Replace(Trim(Replace(Replace(u.Rows(1).Cells(7).Range.Text, Chr(13), ""), Chr(7), "")), " ", "") <> "" Then
u.Rows(1).Cells(7).Range.Text = " " & Cells(w, "E") & Chr(7)
Else
u.Rows(2).Cells(9).Range.Text = " " & Cells(w, "E") & Chr(7)
End If
If s.ActiveDocument.ActiveWindow.ActivePane.Pages.Count > 1 Then
For b = y.Sections(1).Headers.Count To 1 Step -1
If b <> 2 Then
r = r + 1
y.Sections(1).Headers(b).Range.Text = vbTab & vbTab & vbTab & Cells(1, "F") & Format(r, "0##")
y.Sections(1).Headers(b).Range.Font.Name = "Calibri"
y.Sections(1).Headers(b).Range.Font.Size = 9
End If
Next
End If
y.Close savechanges:=True
s.Quit
Next
End Sub

 

[halit3]

Bu kodu bir dene

Private Sub CommandButton1_Click()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")

Yol = ThisWorkbook.Path & "\KL"

ReDim dosyalar3(5000)
Say = 0
For Each dosya In fL.GetFolder(Yol).Files
Uzanti = LCase(fL.GetExtensionName(dosya.Name))
dosya_adi = fL.GetBaseName(dosya)
If Uzanti = "doc" Or Uzanti = "docx" Then
Say = Say + 1
dosyalar3(Say) = dosya
End If
Next


If Say > 0 Then
For i = 1 To Say
Dim objWord As Word.Application
Dim docWord As Word.Document
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set docWord = objWord.Documents.Open(dosyalar3(i))
objWord.ActiveDocument.PageSetup.DifferentFirstPageHeaderFooter = True
veri = Replace(objWord.ActiveDocument.Sections(1).Headers(2).Range.Tables(1).Rows(1).Cells(7).Range.Text, Chr(7), "")
objWord.ActiveDocument.Sections(1).Headers(2).Range.Tables(1).Rows(1).Cells(7).Range.Text = Mid(veri, 1, Len(veri) - 1) & i
docWord.Save
docWord.Close False
objWord.Quit
Set docWord = Nothing
Next
End If

End Sub

 

[1903emre34@gmail.com]

İlginiz için teşekkürler, hata verdi, dosyayı ekledim.

 

[halit3]

Yukarıdaki mesajımdaki kod sizin dosyanızda yok

Private Sub CommandButton1_Click()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim objWord As Word.Application
Dim docWord As Word.Document

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")

Yol = ThisWorkbook.Path & "\KL"
Say = 0

For Each dosya In fL.GetFolder(Yol).Files
Uzanti = LCase(fL.GetExtensionName(dosya.Name))
dosya_adi = fL.GetBaseName(dosya)
If Uzanti = "doc" Or Uzanti = "docx" Then
Say = Say + 1
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
dosyalar3 = dosya
Set docWord = objWord.Documents.Open(dosyalar3)
objWord.ActiveDocument.PageSetup.DifferentFirstPageHeaderFooter = True
veri = Replace(objWord.ActiveDocument.Sections(1).Headers(2).Range.Tables(1).Rows(1).Cells(7).Range.Text, Chr(7), "")
objWord.ActiveDocument.Sections(1).Headers(2).Range.Tables(1).Rows(1).Cells(7).Range.Text = Mid(veri, 1, Len(veri) - 1) & Say
docWord.Save
docWord.Close False
objWord.Quit
Set docWord = Nothing

End If
Next

MsgBox "işlem tamam"


End Sub

 

[1903emre34@gmail.com]

3 nolu mesajda dosya düzenledi.

 

[1903emre34@gmail.com]

Güncel.

 

[halit3]

cevap 2 ve 4 nolu mesajda

 

[1903emre34@gmail.com]

Denedim, hata verdi.

 

[halit3]

Ne hatası alıyorsanız yazsanız iyi olmazmı.?

ekli dosyayı irdeleyiniz.