word dan makroyla excele nasıl veri aktarırım.

[aybekcan]

ANCS 172250Z 23008KT 9999 SCT040 BKN030 diye bir word dosyasında bir metin var bunu excel de hücre içine nasıl teker teker alabiliriz.örnegin a1 hücresine ANCS,A2=172250Z,A3=23008KT,A4=9999 gibi.bunu bir çok defa farklı metinlerle tekrarlamam gerekiyor.bunu nasıl bir macro ile yapabilirim.
yardımlarınız için şimdiden teşekkürler.

 

[Haluk]

Örnek bir Word belgesini www.dosya.tc gibi bir sunucuya yükleyip, linkini buraya yazarsanız, size bir fikir verilebilir.

.

 

[aybekcan]

Hocam word dosyası aşağıdaki adreste.yardımlarınizı bekliyorum.şimdiden teşekkür ediyorum. http://s7.dosya.tc/server4/gjaqox/TTT.docx.html

 

[alicimri]

Dosyanızdaki lk Paragrafınız:LSRO 152240Z 1600/1624 VRB02KT 9999 SCT035 PROB40 TEMPO 1603/1607 -TSRA SCT022CB BKN030 BECMG 1608/1610 21012KT BECMG 1615/1617 VRB02KT CAVOK =
Bu paragraf ve diğerlerini
A Sütununda
LSRO
152240Z
1600/1624
......
Şeklinde listelenmesini mi istiyorsunuz.

 

[alicimri]

Ayrıca "-" ve "=" karakterleri silinecek mi?

 

[aybekcan]

Hocam olması gerekeni ben aşağıdaki linke ekledim.gördüğünüz gibi metin uzunlukları standart değil.bu nedenle her metnin yüklenen excel sayfasında olduğu gibi hücrelere yerleştirilmesi çok önemli.ayrica karakterler "=" işaretine kadar aynı satır üzerine yerleşmesi lazım ve "+,-,=" gibi sembollerin yine sayfada görüldüğü gibi yerleşmesi gerekiyor.ilginiz için teşekkür ederim.ben çok acemiyim nasıl olacağını bulamadım.yadimlarinizi rica ediyorum. http://s7.dosya.tc/server4/4zk59s/TTT.xlsx.html

 

[alicimri]

Dosya yolunu değiştirin. Excel den çalışacak kod aşağıda

Sub a()
Set wordapp = CreateObject("word.Application")
wordapp.Documents.Open ThisWorkbook.Path & "\TTT.docx"
Say = 1
For i = 1 To wordapp.ActiveDocument.Paragraphs.Count
Range("A" & Say).Value = Replace(Replace(Replace(Replace(wordapp.ActiveDocument.Paragraphs(i), "-", "x-"), "+", "x+"), " =", "="), "=", " =")
Say = Say + 1
Next
  Columns(1).TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, TrailingMinusNumbers:=True
        wordapp.ActiveDocument.Close
      Cells.Replace What:="x-", Replacement:="-"
      Cells.Replace What:="x+", Replacement:="+"
        Set wordapp = Nothing
End Sub

 

[alicimri]

Manuel yol
Wordde iken Giriş sekmesinde en sağdaki Seç den Tümünü seç tıklayıp kopyalayın
Excelde A1 hücresini seçip yapıştırıp, tüm A sütununu seçin
Veri sekmesinde Metni Sütunlara dönüştüre tıklayın
Adım 1/3 de Sınılanmış ı seçip, ileri
Adım 2/3 de Boşluk u seçip, ileri
Adım 3/3 de Shift basılı iken teker teker sütunları seçip Metini işaretleyin Son a tıklayın.

 

[aybekcan]

Hocam çok teşekkür ederim.işe yaradı.ama başında "-,+" olduğunda "ad" hatası veriyor.örn. "-shra" ya "ad" hatası veriyor.onu nasıl halledebiliriz acaba?

 

[alicimri]

Yukardaki kodu değiştirdim tekrar deneyin. Bazı Satırlarda "=" bitişikti onu da ayırdım.

 

[aybekcan]

mükemmel çalıştı,elinize sağlık.çok makbule geçti.müteşekkirim...

 

[halit3]

Bu da alternatif olsun

Sub tablo_word1()

Dim objWord As Word.Application
Dim docWord As Word.Document

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

yol = ActiveWorkbook.Path & "\TTT.docx"

Set docWord = objWord.Documents.Open(Filename:=yol, ReadOnly:=True)
'Application.WindowState = wdWindowStateMinimize
'Application.WindowState = wdWindowStateNormal

Say = 1
For i = 1 To objWord.ActiveDocument.Paragraphs.Count
hucre = Trim(objWord.ActiveDocument.Paragraphs(i))

hucre = Replace(Replace(Replace(hucre, "=", "  ="), "  =", " ="), "  =", " =")


deg1 = Split(hucre, " ")
If UBound(deg1) > 0 Then
For j = 0 To UBound(deg1)
If IsNumeric(deg1(j)) = True Then
Cells(Say, j + 1) = deg1(j)
Else
Cells(Say, j + 1) = "'" & deg1(j)
End If

Next j

End If
Say = Say + 1
Next i

docWord.Close False
objWord.Quit

Set docWord = Nothing

MsgBox "işlem tamam"

End Sub

not kodun çalışması için
'referanslar
'Microsoft Word 12.0 Object Library

olmalı

 

[aybekcan]

Mükemmel oldu.çok makbule geçti.müteşekkirim...