• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Excel içinden word satır okuma

H

Hasan_Irgamaz

Katılım
3 Ağustos 2017
Mesajlar
6
Excel Vers. ve Dili
2016 Eng
Merhaba,

VBA ile bir excel sayfasından başka bir word dosyasını açtırarak
word içinde ki belirli alanları alıp excele yazmak istiyorum.

Bununla ilgili google ve forum üzerinden çok araştırma yaptım fakat çözüm bulamadım.

Şu anda excel üzerinden istediğim Word sayfasını aşağıda ki kodlar ile açtırabiliyorum:

Application.ScreenUpdating = False
Dim objWord As New Word.Application
Dim objDoc As New Word.Document
Dim wdFileName As Variant
wdFileName = Application.GetOpenFilename("Word files (*.doc*),*.doc*", , _ "Browse for file containing table to be imported")
Set objDoc = objWord.documents.Open(wdFileName)

Bundan sonrasında ya 1. satırda ki 10. kolondan başla satır sonunna kadar al
ya da Adı: olan metni al gibi bir koda ihtiyacım var.
 
dosya.tc yada dosya.co dan örnek dosyanızı yükleyip , örnek dosyaya göre excel de sonucu el ile yazınız.
Bu şeklide daha hızlı ve doğru sonuç alırsınız.
 
Aşağıdaki şekilde deneyiniz.
Word dosya formatının aynı olduğu varsayılmıştır.


Kod: 
Dim owrd As Word.Application
Dim odoc As Word.Document
Dim singleLine As Paragraph
Dim lineText As String

Sub tablo_word()

'yol = ActiveWorkbook.Path
 yol = "C:\deneme\sartname.docx"

Set owrd = CreateObject("Word.Application")
Set odoc = owrd.Documents.Open(Filename:=yol, Visible:=True)

cumle = ""
say = 0
satir = 1
buldu11 = False
For Each singleLine In ActiveDocument.Paragraphs
    lineText = singleLine.Range.Text
    [COLOR=Red]If Left(lineText, Len("1.1. İdarenin;")) = "1.1. İdarenin;" Then
        buldu11 = True
    End If[/COLOR]
    
    If Left(lineText, Len("2.1. İhale konusu malın")) = "2.1. İhale konusu malın" Then
        buldu21 = True
        buldu11 = False
        say = 0
    End If
    
    If Left(lineText, Len("3.1.")) = "3.1." Then
        buldu31 = True
        buldu11 = False
        buldu21 = False
        say = 0
    End If
    
    If Left(lineText, Len("3.2.")) = "3.2." Then
        buldu31 = False
        buldu11 = False
        buldu21 = False
        say = 0
        Exit For
    End If
    
 [COLOR=Red]   If buldu11 Then
       say = say + 1
       If say = 2 Then
          satir = satir + 1
          Cells(satir, "A").Value = "Adı:"
          Cells(satir, "B").Value = Mid(lineText, InStr(lineText, ":") + 1, Len(lineText))
       End If
       If say = 3 Then
          satir = satir + 1
          Cells(satir, "A").Value = "Adresi:"
          Cells(satir, "B").Value = Mid(lineText, InStr(lineText, ":") + 1, Len(lineText))
       End If
        If say = 4 Then
          satir = satir + 1
          Cells(satir, "A").Value = "Telefon Numarası:"
          Cells(satir, "B").Value = Mid(lineText, InStr(lineText, ":") + 1, Len(lineText))
       End If
       If say = 5 Then
          satir = satir + 1
          Cells(satir, "A").Value = "Fax Numarası"
          Cells(satir, "B").Value = Mid(lineText, InStr(lineText, ":") + 1, Len(lineText))
       End If
       If say = 6 Then
       End If
       If say = 7 Then
          satir = satir + 1
          Cells(satir, "A").Value = "İlgili Personel Adı:"
          Cells(satir, "B").Value = Mid(lineText, InStr(lineText, ":") + 1, Len(lineText))
       End If
    End If[/COLOR]
    
    If buldu21 Then
       say = say + 1
       If say = 2 Then
          satir = satir + 1
          Cells(satir, "A").Value = "Adı:"
          Cells(satir, "B").Value = Mid(lineText, InStr(lineText, ":") + 1, Len(lineText))
       End If
       If say = 3 Then
       End If
       If say = 4 Then
       End If
       If say = 5 Then
          satir = satir + 1
          Cells(satir, "A").Value = "Miktarı ve Türü:"
          Cells(satir, "B").Value = Mid(lineText, InStr(lineText, ":") + 1, Len(lineText))
       End If
       If say = 6 Then
       End If
       If say = 7 Then
          satir = satir + 1
          Cells(satir, "A").Value = "Teslim Edileceği Yer:"
          Cells(satir, "B").Value = Mid(lineText, InStr(lineText, ":") + 1, Len(lineText))
       End If
    End If
    
    If buldu31 Then
       say = say + 1
       If say = 2 Then
          satir = satir + 1
          Cells(satir, "A").Value = "İhale kayıt numarası: "
          Cells(satir, "B").Value = Mid(lineText, InStr(lineText, ":") + 1, Len(lineText))
       End If
       If say = 3 Then
       End If
       If say = 4 Then
          satir = satir + 1
          Cells(satir, "A").Value = "Tekliflerin sunulacağı adres"
          Cells(satir, "B").Value = Mid(lineText, InStr(lineText, ":") + 1, Len(lineText))
       End If
       If say = 5 Then
          satir = satir + 1
          Cells(satir, "A").Value = "İhalenin yapılacağı adres: "
          Cells(satir, "B").Value = Mid(lineText, InStr(lineText, ":") + 1, Len(lineText))
       End If
     
       If say = 6 Then
          satir = satir + 1
          Cells(satir, "A").Value = "İhale (son teklif verme) tarihi:"
          Cells(satir, "B").Value = Mid(lineText, InStr(lineText, ":") + 1, Len(lineText))
       End If
       
       If say = 7 Then
          satir = satir + 1
          Cells(satir, "A").Value = "İhale (son teklif verme) saati:"
          Cells(satir, "B").Value = Mid(lineText, InStr(lineText, ":") + 1, Len(lineText))
       End If
       If say = 8 Then
          satir = satir + 1
          Cells(satir, "A").Value = "İhale komisyonunun toplantı yeri:"
          Cells(satir, "B").Value = Mid(lineText, InStr(lineText, ":") + 1, Len(lineText))
       End If
    End If
    
Next singleLine
    odoc.Application.NormalTemplate.Saved = True
    odoc.Close False
    Set odoc = Nothing
End Sub
 
Son düzenleme:
Merhaba, ilginiz için teşekkür ederim.
Şu an bir sağlık probleminden dolayı kodları deniyemiyorum.
Hafta sonu kontrol edip bilgi vereceğim.
 
Merhaba,

İyi dilekleriniz ve yardımınız için teşekkürler.

Bu kodlar çok işime yaradı.
 
Aynı dökümanda ki 5.1 madde ç bendinde yer alan virgül ile ayrılmış her bir formu ayrı ayrı nasıl alabilirim acaba?
Amacım burada yer alan belgelerin hepsini yeni açacağım bir forma ekleyerek bir kontrol listesi oluşturamak ve hazır olan evrakların onaylanmasını sağlayabilmek.
 
Hasan_Irgamaz' Alıntı:
Aynı dökümanda ki 5.1 madde ç bendinde yer alan virgül ile ayrılmış her bir formu ayrı ayrı nasıl alabilirim acaba?
Amacım burada yer alan belgelerin hepsini yeni açacağım bir forma ekleyerek bir kontrol listesi oluşturamak ve hazır olan evrakların onaylanmasını sağlayabilmek.
Genişletmek için tıkla ...

Kodda boyadığım yerlerdeki satırları, kopyalayıp yeni maddelere ve madde içindeki satırlara göre düzenleyebilir siniz.

Bu şekilde istediğiiz kadar madde ekleyebilirsiniz.
 
Merhaba,

İlgili kodlarda, alınacak metin başlığının bilindiği varsayılmış.
Halbuki benim alacağım değerler değişken fakat hep aynı yerdeler. (5.1 ç bendinde)


Ben Wordden koordinat bildirerek veri alamaz mıyım? 5. satır 3. kolondan başla 5 karakter al ya da şu satırdan başla virgül ile ayrılmış her bir değeri bir değişkene ata gibi.

C# Substr() Fonksiyonu gibi.
 
Alternatif olarak kod:
Kod: 
Sub tablo_word11()
dosyaadi = ThisWorkbook.Name
Range("B2:M500").ClearContents
Dosya = Cells(1, 1)
yol = ActiveWorkbook.Path & "\" & Dosya & ".doc"
Dim objWord As Word.Application
Dim docWord As Word.Document

Set objWord = CreateObject("Word.Application")
objWord.Visible = True

Set docWord = objWord.Documents.Open(yol)
ActiveDocument.Application.WindowState = wdWindowStateMinimize
Windows(dosyaadi).Activate
sat = 1

If objWord.ActiveDocument.Tables.Count > 0 Then
For i = objWord.ActiveDocument.Tables.Count To 1 Step -1
objWord.ActiveDocument.Tables(i).Delete
Next i
End If

For s = 1 To objWord.ActiveDocument.Paragraphs.Count
bulunan = Replace(Replace(objWord.ActiveDocument.Paragraphs(s).Range.Text, Chr(13), ""), "", "")
For i = 2 To Cells(Rows.Count, "a").End(3).Row
aranan = Cells(i, "a")
If aranan = Mid(bulunan, 1, Len(aranan)) Then
sat = sat + 1
Cells(sat, 2) = bulunan
End If
Next i
Next s
docWord.Close False
objWord.Quit
Set docWord = Nothing


MsgBox "işlem tamam"



End Sub

Açıklama
Kodu bir excel dosyasının modülüne kopyalayınız excel dosyası ile veri alınacak word dosyası aynı yerde olmalı A1 Hücresine dosya adını uzantısıs yazın örneğin (deneme) A2 Hücresinden başlayıp A Sütuna aranan kelimeyi yazın örneğin

A2 Hücresi için =3.5.
A3 Hücresi için =3.6.
A4 Hücresi için =4.1.
A5 Hücresi için =4.2.
A6 Hücresi için =4.3.

kodu çalıştırın

dikkat kodun çalışması için referenslarda
Kod: 
Microsoft Word 12.0 Object Library
bu olmalı
 
Bu kod da birazcık farklı

Kod: 
Sub tablo_word2()
dosyaadi = ThisWorkbook.Name
Range("B2:M500").ClearContents
Dosya = Cells(1, 1)
yol = ActiveWorkbook.Path & "\" & Dosya & ".doc"
Dim objWord As Word.Application
Dim docWord As Word.Document

Set objWord = CreateObject("Word.Application")
objWord.Visible = True

Set docWord = objWord.Documents.Open(yol)
ActiveDocument.Application.WindowState = wdWindowStateMinimize
Windows(dosyaadi).Activate
sat = 1

If objWord.ActiveDocument.Tables.Count > 0 Then
For i = objWord.ActiveDocument.Tables.Count To 1 Step -1
objWord.ActiveDocument.Tables(i).Delete
Next i
End If

For s = 1 To objWord.ActiveDocument.Paragraphs.Count
bulunan = Replace(Replace(objWord.ActiveDocument.Paragraphs(s).Range.Text, Chr(13), ""), "", "")
For i = 2 To Cells(Rows.Count, "a").End(3).Row
aranan1 = Cells(i, "a")

If aranan1 = Mid(bulunan, 1, Len(aranan1)) Then
say = 0

For j = s To objWord.ActiveDocument.Paragraphs.Count

bulunan2 = Replace(Replace(objWord.ActiveDocument.Paragraphs(j).Range.Text, Chr(13), ""), "", "")

say = say + 1
If say > 1 Then
If Mid(bulunan2, 2, 1) = "." Then Exit For
End If

sat = sat + 1
Cells(sat, 2) = bulunan2


Next j

End If
Next i
Next s
docWord.Close False
objWord.Quit
Set docWord = Nothing


MsgBox "işlem tamam"



End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst