Word sayfasındaki tarihleri aktarılması hk.

turist

Destek Ekibi
Destek Ekibi
Katılım
18 Kasım 2009
Mesajlar
5,102
Excel Vers. ve Dili
2013 64Bit
English
Deneyiniz.

Kod:
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
x = Replace(u.Rows(3).Cells(6).Range.Text, Chr(7), "")
Cells(sat, "AA") = CDbl(DateValue(x))
sat = sat + 1
  End If
Next

s.Quit
y.Close
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)
If WorksheetFunction.CountIf(Range("AA1:AA" & j.Row), j.Value) = 1 Then
sat = sat + 1
Cells(sat, sut) = Format(j, "dd.mm.yyyy")
If sat = 12 Then sat = 8: sut = sut + 1
End If
Next
[AA:AA] = Empty
End Sub
 

1903emre34@gmail.com

Altın Üye
Katılım
29 Mayıs 2016
Mesajlar
881
Excel Vers. ve Dili
Microsoft Excel 2013 Türkçe
İlginiz için teşekkürler, 1 nolu dosyada çalıştı, ekteki dosyada bazı tarihler gelmedi, size zahmet bakabilir misiniz?
 

Ekli dosyalar

Üst