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

ugurrrrrr · 21 Şubat 2008

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 · 23 Şubat 2008

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 · 24 Şubat 2008

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 · 29 Şubat 2008

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 · 29 Şubat 2008

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 · 4 Mart 2008

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 · 4 Mart 2008

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

ugurrrrrr · 4 Mart 2008

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

Ferhat Pazarçevirdi · 4 Mart 2008

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

Kod:

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 · 4 Mart 2008

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 · 4 Mart 2008

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 · 4 Mart 2008

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 · 4 Mart 2008

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

Ferhat Pazarçevirdi · 4 Mart 2008

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

Kod:

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 · 4 Mart 2008

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 · 4 Mart 2008

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 · 4 Mart 2008

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 · 4 Mart 2008

Ç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 · 4 Mart 2008

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

Kod:

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 · 4 Mart 2008

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

Kod:

Sub Word_Doc_Bilgi_Al()
Dim wrd, doc, klasor
Dim m&#37;, i%, x%, y%, j%
Dim dizin As String, adres As String
Dim arrBaslik()
arrBaslik = Array("TC Kimlik No", "Ad&#305; Soyad&#305;", "&#304;kametgah Adresi", "TC Kimlik No", _
                  "Ad&#305; Soyad&#305;", "Do&#287;um Yeri", "Do&#287;um Tarihi", "E&#351;", "&#199;ocuk", "Ana", "Baba", "Erkek", "Kad&#305;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&#252;tfen bir klas&#246;r se&#231;in !", &H100)
If klasor Is Nothing Then
   MsgBox "Herhangi bir klas&#246;r se&#231;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&#351;:" 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

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

ugurrrrrr

tahsinanarat

merken

ugurrrrrr

ugurrrrrr

ugurrrrrr

Ferhat Pazarçevirdi

Özel Üye

ugurrrrrr

Ferhat Pazarçevirdi

Özel Üye

ugurrrrrr

Ferhat Pazarçevirdi

Özel Üye

ugurrrrrr

Ferhat Pazarçevirdi

Özel Üye

Ferhat Pazarçevirdi

Özel Üye

ugurrrrrr

Ferhat Pazarçevirdi

Özel Üye

ugurrrrrr

ugurrrrrr

Ferhat Pazarçevirdi

Özel Üye

ugurrrrrr