Word'den excel'e veri aktarımı (900 ad. dosyadan)

[ugurrrrrr]

Arkadaşlar merhaba.
Elimde yaklaşık 900 adet word dosyası bulunmakta. Bunların formatları birbirleri ile aynı (vizite kağıd&#305.
Benim sorum bu dosyalardaki bilgileri bir excel sayfasına nasıl aktarırız. Tabiki tek tek dosyalarla uğraşmadan toplu olarak isimlerini seçip bilgileri aktaracağız.
Ekte bir adet örnek dosya var. Yardımlarınız için şimdiden teşekkür ederim.
Not: Dosyanın içeriğinde gerekli olan alanlar kırmızı olarak işaretlenmiştir.

 

[tahsinanarat]

fazla pratik olmasada bir çözüm

Aktarma yapacağın word dosyasını açarak düzenden tümünü seç ve kopyala yaptıktan sonra gönderdiğim excel dosyasına geçip makroları butona basmak suretiyle çalıştırdığında istediğin kırmızı renkli datalarının data sayfasına sırayla yapıştırdığını göreceksin, her aktarmak istediğin word dosyasında aynı işlemi yapmak suretiyle bilgilerini alacaksın. Hiç yoktan iyidir diye düşünüyorum. Kolay gelsin

 

[merken]

tum word dosyalarini tek bi klasorde toplayin
bos bir word acin
insert > file > (tum dosyalari shift ile secerek tek bir dosyanin icinde birlestirin)

devaminda ya sn.tahsinanarat'inki gibi bir makroyla gidersiniz yada daha kolay olan yolu tek wordde topladiginiz bilgileri excele copy paste ile atip periyodik olarak ilerleyen istediginiz hucreleri filtrelersiniz (B kolonunda "T.C. Kimlik No" olanlar, "Adı ve Soyadı" olanlar gibi gibi)

istediginiz listeye en fazla 10 dk'da ulasirsiniz..

 

[ugurrrrrr]

Arkadaşlar teşekkürler. Söylediklerinizi deneyeceğim. Ama bunu kapalı word dosyası üzerinden execelde yapmanın bir yolu varmı ? Eğer var ise işlem daha kolaylaşır diye düşünüyorum.

 

[ugurrrrrr]

Arkadaşlar önermiş olduğunuz yolu denedim. makro gayet güzel çalışıyor.
Ama Ekle komutu ile 900 ad dosyayı worde ekleyemiyorum. Sanırım bir sınırlandırma var. belli bir adetten yukarısını eklemiyor.Gruplar halinde yapmayıda denedim olmuyor.

 

[ugurrrrrr]

Malesef wordden kopyala yapıştır ile bütün dosyaları yapıştıramıyorum. (çoklu halde) bir el atarsanız iyi olur.

 

[Ferhat Pazarçevirdi]

Direkt kopyalama ile Word'deki gibi bir görüntü elde edemeyebilirsiniz.

 

[ugurrrrrr]

Benim için mühim olan verileri excel'e aktarmak. Biçim önemli değil

 

[Ferhat Pazarçevirdi]

Bahsettiğiniz 900 dosyayı tek bir dizin altına alın ve aşağıdaki kodu kullanın.

Sub Word_Doc_Kopyala()
Dim wrd, doc, klasor
Dim m%, i%, x%, y%, j%
Dim dizin As String
Set klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin !", &H100)
If klasor Is Nothing Then
   MsgBox "Herhangi bir klasör seçmediniz", vbCritical, "UYARI"
   Exit Sub
Else
   dizin = klasor.Items.Item.Path
End If
Set wrd = CreateObject("Word.Application")
wrd.Application.Visible = False
With Application.FileSearch
    .NewSearch
    .LookIn = dizin
    .FileType = msoFileTypeWordDocuments
    .Execute
    If .FoundFiles.Count > 0 Then
       m = 1
       For i = 1 To .FoundFiles.Count
           Set doc = wrd.Documents.Open(.FoundFiles(i))
           With doc.ActiveWindow.Selection
               .WholeStory
               .Copy
           End With
           Sheets.Add after:=Sheets(Sheets.Count)
           With ThisWorkbook.ActiveSheet
                .Name = i 'Mid(.FoundFiles(i), Len(dizin) + 2, Len(.FoundFiles(i)) - Len(dizin))
                .Range("A1").Select
                .Paste
           End With
           doc.Close 0
       Next i
    End If
End With
wrd.Quit
Set klasor = Nothing
Set doc = Nothing
Set wrd = Nothing
End Sub

 

[ugurrrrrr]

Ferhat Pazarçevirdi teşekkürler.
Peki sorumun ilk başında sorduğum gibi bu dosyaların sadece bir kısmını (sadece belirli alanlar&#305 aynı sayfaya kopyalamak mümkünmü?

 

[Ferhat Pazarçevirdi]

Ben yanlış anladım heralde ... Tüm dosya içeriğinin çekileceği üzerinden bir mantık kurmuştum.

Olabilir tabi ... Tab değerlerini bildikten sonra Excel'e çekilir.

Yani, sizin tam olarak istediğiniz; Word dosyasındaki kırmızı işaretlenen bilgileri, Excel'de bir sheet'e 7 sütunlu bir Liste olarak, satır satır aktarmak mı?

 

[ugurrrrrr]

Evet 11 sütunlu bir liste olarak aktarmak. Yanlız eş , çocuk ,ana ,baba, erkek , kadın kısmındaki chek işaretinide (1 yada 0 olarak) almam gerekiyor.

 

[Ferhat Pazarçevirdi]

Hadi eş, çocuk, erkek/kadın tamam ... Ama "ana", "baba" nerde güzel kardeşim ...

 

[Ferhat Pazarçevirdi]

Aşağıdaki kodu çalıştırınız.

Sub Word_Doc_Bilgi_Al()
Dim wrd, doc, klasor
Dim m%, i%, x%, y%, j%
Dim dizin As String, adres As String
Dim arrBaslik()
arrBaslik = Array("TC Kimlik No", "Adı Soyadı", "İkametgah Adresi", "TC Kimlik No", _
                  "Adı Soyadı", "Doğum Yeri", "Doğum Tarihi", "Eş", "Çocuk", "Erkek", "Kadın", "TC")
y = 1
For i = 0 To UBound(arrBaslik)
    Cells(1, i + 1) = arrBaslik(i)
Next i
Set klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin !", &H100)
If klasor Is Nothing Then
   MsgBox "Herhangi bir klasör seçmediniz", vbCritical, "UYARI"
   Exit Sub
Else
   dizin = klasor.Items.Item.Path
End If
Set wrd = CreateObject("Word.Application")
wrd.Application.Visible = True
On Error Resume Next
With Application.FileSearch
    .NewSearch
    .LookIn = dizin
    .FileType = msoFileTypeWordDocuments
    .Execute
    If .FoundFiles.Count > 0 Then
       m = 1
       For i = 1 To .FoundFiles.Count
           Set doc = wrd.Documents.Open(.FoundFiles(i))
           y = y + 1
           Cells(y, 1) = Application.WorksheetFunction.Clean(doc.Tables(2).Range.Cells(4))
           Cells(y, 2) = Application.WorksheetFunction.Clean(doc.Tables(2).Range.Cells(11))
               adres = Application.WorksheetFunction.Clean(doc.Tables(3).Range.Cells(5))
               adres = Mid(adres, 20, Len(adres) - 20 - 28)
           Cells(y, 3) = adres 'Mid(Application.WorksheetFunction.Clean(doc.Tables(3).Range.Cells(5)), 20, 1)
           Cells(y, 4) = Application.WorksheetFunction.Clean(doc.Tables(3).Range.Cells(8))
           Cells(y, 5) = Application.WorksheetFunction.Clean(doc.Tables(3).Range.Cells(11))
           Cells(y, 6) = Application.WorksheetFunction.Clean(doc.Tables(3).Range.Cells(20))
           Cells(y, 7) = Application.WorksheetFunction.Clean(doc.Tables(3).Range.Cells(21))
           Cells(y, 8) = IIf(doc.FormFields.Item(4).CheckBox.Value = True, 1, 0)
           Cells(y, 9) = IIf(doc.FormFields.Item(5).CheckBox.Value = True, 1, 0)
           Cells(y, 10) = IIf(doc.FormFields.Item(6).CheckBox.Value = True, 1, 0)
           Cells(y, 11) = IIf(doc.FormFields.Item(7).CheckBox.Value = True, 1, 0)
           Cells(y, 12) = IIf(doc.FormFields.Item(8).CheckBox.Value = True, 1, 0)
           doc.Close 0
       Next i
    End If
End With
wrd.Quit
Set klasor = Nothing
Set doc = Nothing
Set wrd = Nothing
End Sub

 

[ugurrrrrr]

Pardon aynı formun farklı versiyonunda var. Eş ve çocuk ile aynı yerdeler. Ama Eş yazan yerde Ana , Çocuk yazan yerde Baba Yazıyor. dolayısıyla bu başlıklarıda almam gerekiyor. Eş=1 yada Eş=0 gibi

 

[Ferhat Pazarçevirdi]

Belgelerin hepsi aynı dizayn da değilse; yukarıda verdiğim kod çuvallayabilir ... Çünkü, nesne (onay kutular&#305 ve tab'lar farklı konuma ve indexlere sahip olabilirler.

 

[ugurrrrrr]

Ferhat Pazarçevirdi çok çok teşekkür ederim.
Verdiğiniz kod tam istediğim gibi yanlız iki sütün daha ekleyip eş - ana , çocuk - baba sorgulaması yaptıktan sonra ilgili sütuna yazmam gerekiyor.

 

[ugurrrrrr]

Çok oluyorsun demesseniz sizden bir yardım daha isteyeceğim.
Hürriyet Mah. İstiklal Cad. No:1 GEBZE / KOCAELİ
Şeklinde yazılmış birbirinden farklı uzunluklarda adresler var.
Bu adreslerin sonunda yer alan İLÇE ve İL hanelerini adresten ayırmam gerekiyor. Yanlız ilçe ve il isimleride farklılıklar gösteriyor.
Hürriyet Mah. İstiklal Cad. No:1 GEBZE KOCAELİ şeklinde.

 

[Ferhat Pazarçevirdi]

Aşağıdaki kodları kullanınız ...

Option Base 1
Dim arrHarf()
Sub Word_Doc_Bilgi_Al()
Dim wrd, doc, klasor
Dim m%, i%, x%, y%, j%, durum%
Dim dizin As String, adres As String
Dim arrBaslik()
arrBaslik = Array("TC Kimlik No", "Adı Soyadı", "İkametgah Adresi", "TC Kimlik No", _
                  "Adı Soyadı", "Doğum Yeri", "Doğum Tarihi", "Eş", "Çocuk", "Erkek", "Kadın", "TC", "İl", "İlçe")
ReDim arrHarf(116)
For i = 1 To 116
    If i <= 26 Then arrHarf(i) = Chr(i + 64)
    If i > 26 And i <= 53 Then arrHarf(i) = Chr(i + 70)
    If i > 53 Then arrHarf(i) = Chr(i + 139)
Next i
    
y = 1
For i = 1 To UBound(arrBaslik)
    Cells(1, i) = arrBaslik(i)
Next i
Set klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin !", &H100)
If klasor Is Nothing Then
   MsgBox "Herhangi bir klasör seçmediniz", vbCritical, "UYARI"
   Exit Sub
Else
   dizin = klasor.Items.Item.Path
End If
Set wrd = CreateObject("Word.Application")
wrd.Application.Visible = True
On Error Resume Next
With Application.FileSearch
    .NewSearch
    .LookIn = dizin
    .FileType = msoFileTypeWordDocuments
    .Execute
    If .FoundFiles.Count > 0 Then
       m = 1
       For i = 1 To .FoundFiles.Count
           Set doc = wrd.Documents.Open(.FoundFiles(i))
           y = y + 1
           Cells(y, 1) = Application.WorksheetFunction.Clean(doc.Tables(2).Range.Cells(4))
           Cells(y, 2) = Application.WorksheetFunction.Clean(doc.Tables(2).Range.Cells(11))
               adres = Application.WorksheetFunction.Clean(doc.Tables(3).Range.Cells(5))
               adres = Mid(adres, 20, Len(adres) - 20 - 28)
           Cells(y, 3) = adres 'Mid(Application.WorksheetFunction.Clean(doc.Tables(3).Range.Cells(5)), 20, 1)
           Cells(y, 4) = Application.WorksheetFunction.Clean(doc.Tables(3).Range.Cells(8))
           Cells(y, 5) = Application.WorksheetFunction.Clean(doc.Tables(3).Range.Cells(11))
           Cells(y, 6) = Application.WorksheetFunction.Clean(doc.Tables(3).Range.Cells(20))
           Cells(y, 7) = Application.WorksheetFunction.Clean(doc.Tables(3).Range.Cells(21))
           Cells(y, 8) = IIf(doc.FormFields.Item(4).CheckBox.Value = True, 1, 0)
           Cells(y, 9) = IIf(doc.FormFields.Item(5).CheckBox.Value = True, 1, 0)
           Cells(y, 10) = IIf(doc.FormFields.Item(6).CheckBox.Value = True, 1, 0)
           Cells(y, 11) = IIf(doc.FormFields.Item(7).CheckBox.Value = True, 1, 0)
           Cells(y, 12) = IIf(doc.FormFields.Item(8).CheckBox.Value = True, 1, 0)
           
           Cells(y, 13) = AdresAyir(adres)
           
           adres = Mid(adres, 1, Len(adres) - Len(Cells(y, 13)))
           Cells(y, 14) = AdresAyir(adres)
           doc.Close 0
       Next i
    End If
End With
wrd.Quit
Set klasor = Nothing
Set doc = Nothing
Set wrd = Nothing
End Sub
'--------------------------------------------------------------
'--------------------------------------------------------------
Private Function AdresAyir(adres As String)
Dim g%, u%, durum%
Dim adr As String
For g = 1 To Len(adres)
        For u = 1 To UBound(arrHarf)
                If Mid(StrReverse(adres), g, 1) = arrHarf(u) Then durum = durum + 1
        Next u
        If durum = 0 Then
                If Len(adr) > 0 Then
                       Exit For
                End If
        Else
               adr = adr & Mid(StrReverse(adres), g, 1)
               durum = 0
        End If
Next g
AdresAyir = Trim(StrReverse(adr))
End Function

 

[ugurrrrrr]

Kodu Ana Baba İçin aşağıdaki gibi düzenledim.

Sub Word_Doc_Bilgi_Al()
Dim wrd, doc, klasor
Dim m%, i%, x%, y%, j%
Dim dizin As String, adres As String
Dim arrBaslik()
arrBaslik = Array("TC Kimlik No", "Adı Soyadı", "İkametgah Adresi", "TC Kimlik No", _
                  "Adı Soyadı", "Doğum Yeri", "Doğum Tarihi", "Eş", "Çocuk", "Ana", "Baba", "Erkek", "Kadın", "TC")
y = 1
For i = 0 To UBound(arrBaslik)
    Cells(1, i + 1) = arrBaslik(i)
Next i
Set klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin !", &H100)
If klasor Is Nothing Then
   MsgBox "Herhangi bir klasör seçmediniz", vbCritical, "UYARI"
   Exit Sub
Else
   dizin = klasor.Items.Item.Path
End If
Set wrd = CreateObject("Word.Application")
wrd.Application.Visible = True
On Error Resume Next
With Application.FileSearch
    .NewSearch
    .LookIn = dizin
    .FileType = msoFileTypeWordDocuments
    .Execute
    If .FoundFiles.Count > 0 Then
       m = 1
       For i = 1 To .FoundFiles.Count
           Set doc = wrd.Documents.Open(.FoundFiles(i))
           y = y + 1
           Cells(y, 1) = Application.WorksheetFunction.Clean(doc.Tables(2).Range.Cells(4))
           Cells(y, 2) = Application.WorksheetFunction.Clean(doc.Tables(2).Range.Cells(11))
               adres = Application.WorksheetFunction.Clean(doc.Tables(3).Range.Cells(5))
               adres = Mid(adres, 20, Len(adres) - 20 - 28)
           Cells(y, 3) = adres 'Mid(Application.WorksheetFunction.Clean(doc.Tables(3).Range.Cells(5)), 20, 1)
           Cells(y, 4) = Application.WorksheetFunction.Clean(doc.Tables(3).Range.Cells(8))
           Cells(y, 5) = Application.WorksheetFunction.Clean(doc.Tables(3).Range.Cells(11))
           Cells(y, 6) = Application.WorksheetFunction.Clean(doc.Tables(3).Range.Cells(20))
           Cells(y, 7) = Application.WorksheetFunction.Clean(doc.Tables(3).Range.Cells(21))
                es = Application.WorksheetFunction.Clean(doc.Tables(3).Range.Cells(4))
                es = Mid(es, 1, 3)
                If es = "Eş:" Then
           Cells(y, 8) = IIf(doc.FormFields.Item(4).CheckBox.Value = True, 1, 0)
           Cells(y, 9) = IIf(doc.FormFields.Item(5).CheckBox.Value = True, 1, 0)
               End If
               If es = "Ana" Then
           Cells(y, 10) = IIf(doc.FormFields.Item(4).CheckBox.Value = True, 1, 0)
           Cells(y, 11) = IIf(doc.FormFields.Item(5).CheckBox.Value = True, 1, 0)
                End If
           Cells(y, 12) = IIf(doc.FormFields.Item(6).CheckBox.Value = True, 1, 0)
           Cells(y, 13) = IIf(doc.FormFields.Item(7).CheckBox.Value = True, 1, 0)
           Cells(y, 14) = IIf(doc.FormFields.Item(8).CheckBox.Value = True, 1, 0)
           doc.Close 0
       Next i
    End If
End With
wrd.Quit
Set klasor = Nothing
Set doc = Nothing
Set wrd = Nothing
End Sub