Üst bilgi kısmında yer alan tarihlerin, tablolarda gösterilmesi

[1903emre34@gmail.com]

Merhabalar,

Tablo1 dosyada, veri al bastığımız zaman, klasör içerisinde yer alan word dosyalarının üst bilgi kısmında yer alan tarihleri yerleştirecek şekilde nasıl kod oluşturabiliriz

 

[1903emre34@gmail.com]

Konu guncel

 

[PLİNT]

Konu guncel

Merhaba
Burayada örneğinizi ekleyip link verirmisiniz?

 

[1903emre34@gmail.com]

Merhaba, Üstad

Dosya link ekte gibidir.


http://s9.dosya.tc/server2/2qkoai/Dosya_1.zip.html

 

[PLİNT]

Merhaba
Ek dosyayı deneyin
http://s9.dosya.tc/server2/qw81be/Dosya_2.zip.html
"Hazırlama Tarihi" için;

[SIZE="2"]Sub veri()
 Range("E9:H" & Rows.Count) = Empty
Dim ds, dc, f, s, y, u, dosya
Dim sat, sut As Integer
Dim x As String
Set ds = CreateObject("Scripting.FileSystemObject")
Set f = ds.GetFolder(ThisWorkbook.Path & "\")
Set dc = f.Files
 Set s = CreateObject("Word.Application")
 sat = 9: sut = 4
On Error Resume Next
For Each dosya In dc
If ds.GetExtensionName(dosya.Name) Like "doc*" Then
Set y = s.Documents.Open(ThisWorkbook.Path & "\" & dosya.Name)
s.Visible = False
sut = sut + 1
 Set u = y.Sections(1).Headers(2).Range.tables(1)
[COLOR="Red"]x = Replace(u.Rows(2).Cells(6).Range.Text, Chr(7), "")[/COLOR]
Cells(sat, sut) = Format(x, "dd.mm.yyyy")
y.Close
  End If
If sut = 8 Then sut = 4: sat = sat + 1
 Next
 s.Quit
End Sub [/SIZE]

"İnceleme Tarih" için isterseniz; kırmızı bölümü şöyle değiştirirsiniz;

[SIZE="2"]x = Replace(u.Rows(3).Cells(9).Range.Text, Chr(7), "") [/SIZE]

 

[1903emre34@gmail.com]

Hocam, teşekkür ederim

Sırasıyla yapmak istesek kodlarda nasıl değişik yapabiliriz

01.01.2016
01.02.2016
01.03.2016 vs.

 

[PLİNT]

Yine "E" sütunu 9. satırdan başlayacaksa:

[SIZE="2"] Sub veri()
 Range("E9:H" & Rows.Count) = Empty
 [AA:AA] = Empty
Dim ds, dc, f, s, y, u, dosya
Dim sat, sut As Integer
Dim x As String
Set ds = CreateObject("Scripting.FileSystemObject")
Set f = ds.GetFolder(ThisWorkbook.Path & "\")
Set dc = f.Files
 Set s = CreateObject("Word.Application")
 sat = 1
On Error Resume Next
For Each dosya In dc
If ds.GetExtensionName(dosya.Name) Like "doc*" Then
Set y = s.Documents.Open(ThisWorkbook.Path & "\" & dosya.Name)
s.Visible = False
 Set u = y.Sections(1).Headers(2).Range.tables(1)
x = Replace(u.Rows(2).Cells(6).Range.Text, Chr(7), "")
Cells(sat, "AA") = CDbl(DateValue(x))
sat = sat + 1
y.Close
  End If
 Next
 s.Quit
 A = Cells(Rows.Count, "AA").End(xlUp).Row
Range("AA1:AA" & A).Sort Key1:=Cells(1, "AA"), Order1:=xlAscending
sat = 8: sut = 5
For Each j In Range("AA1:AA" & A)
sat = sat + 1
Cells(sat, sut) = Format(j, "dd.mm.yyyy")
If sat = 12 Then sat = 8: sut = sut + 1
Next
 [AA:AA] = Empty
End Sub[/SIZE]

 

[1903emre34@gmail.com]

Resimde ki gibi,

 

[PLİNT]

Yukarıdaki (7.mesaj) değişen kodları deneyin dosya adları sadece ay adlarına göre olmadığı için yardımcı sütun kullanarak olabilir.

 

[1903emre34@gmail.com]

Hocam; çok teşekkürler, ellerinize sağlık

Hayırlı geceler