Wordden belli değerleri excel tablosuna aktarma

[hande723]

Merhaba,

Benim söyle bir sorunum var bir hesap programı çıktısını WORD olarak vermektedir. ben bu dosyadaki 3 tane veriyi makro sayesinde excelde oluşturduğum tablonun istediğim yerlerine otomatik yazılmasını istiyorum. Bu mümkün müdür?


Linkleri ekledim. Amacım; wordde sarı ile işaretli verileri excelde yeşil ile işaretli sutunlara otomatik gecmesini sağlamak

http://s5.dosya.tc/server4/ptd8w3/UHTCAL.rar.html

 

[Asri]

Örnek veriler içeren Excel ve Word dosyalarınızı dosya.tc yada dosya.co dan yükleyip link verirseniz. Daha hızlı çözüm bulursunuz.

 

[hande723]

Hatırlatma için teşekkürler. Ekledim

 

[Asri]

Hatırlatma için teşekkürler. Ekledim

Konuyu siz bildiğiniz için basit gibi duruyor. Ben tablolardan birşey anlamadım.

Yeşil alanlara rastgele mi yazılacak
word deki tüm tablolardaki aynı satırlar mı aktarılacak.
Aktarma sırasında kurallar nedir. Excel de hangi satıra hangi verinin yazılacağı neye göre belirleniyor.

Kısacası tüm tablolar aktarılacak ise bir tablo için işlem adımlarını tek tek yazmanız sonuca ulaşılması için yararlı olur.

 

[hande723]

ya biraz anlaşılması güç olmuş evet.
Şöyle açıklamaya çalışayım;

Wordden Total Zone Loads satırında yazan Sensible/Latent/Sensible sütunlarına denk gelen verileri, excel de ilgili mahaldeki Duyulu/Gizli/Isı kaybı sütünlarında ki değerlere sırayla yazmasını istiyorum. Excel liste sırası ile Word sırası aynı, yani 1.sayfa excel de 1.satıra, wordde 2.sayfa excelde 2.satıra olacak şekilde

 

[Asri]

Tahmini word deki sırayıa bakıp excel deki aynı sıra ile yazmak pek sağlıklı durmuyor ama,

Excel de Modul1 e kopyalayıp deneyiniz.

Her tablonun başlangıcında TABLE olmak zorunda.
Veri alınacak satırda "Total Zone Loads" olmak zorunda.

Dim owrd As Word.Application
Dim odoc As Word.Document

Sub tablo_word()

yol = ActiveWorkbook.Path
yol = yol & "\22C-24C.rtf"

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

Dim singleLine As Paragraph
Dim lineText As String
cumle = ""
say = 0
satir = 4
For Each singleLine In ActiveDocument.Paragraphs
    lineText = singleLine.Range.Text
    If InStr(lineText, "Total Zone Loads") > 0 Then
        buldu = True
    End If

    If InStr(lineText, "TABLE") > 0 Then
        buldu = False
        cumle = ""
        say = 0
    End If
    
    If buldu Then
       say = say + 1
       If say = 3 Then deg1 = lineText
       If say = 4 Then deg2 = lineText
       If say = 6 Then
          deg3 = lineText
          satir = satir + 1
          Cells(satir, "I").Value = sadecesayi(deg1)
          Cells(satir, "J").Value = sadecesayi(deg2)
          Cells(satir, "M").Value = sadecesayi(deg3)
       End If
    End If
    
Next singleLine

    odoc.Application.NormalTemplate.Saved = True
    odoc.Close False
    Set odoc = Nothing
End Sub

Function sadecesayi(sadecesayistr) As String
  liste = "0123456789"
  For k = 1 To Len(sadecesayistr)
    harf = Mid(sadecesayistr, k, 1)
    If InStr(liste, harf) = 0 Then
       Exit For
    End If
  Next k
  gecici = Mid(sadecesayistr, 1, k - 1)
  If gecici = "" Then gecici = "0"
  sadecesayi = gecici
End Function

 

[halit3]

Sorunuzu anlamadım farklı bir yaklaşımla bir kodda ben yazdım.
kod veri dosyasındaki tabloların en son satırındaki bütün değerleri getiriyor.

Sub tablo_word()

yol = ActiveWorkbook.Path
yol = yol & "\22C-24C.rtf"

Dim owrd As Word.Application
Dim odoc As Word.Document


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

If owrd.ActiveDocument.Tables.Count > 0 Then
For i = 1 To owrd.ActiveDocument.Tables.Count
satson = owrd.ActiveDocument.Tables(i).Rows.Count
sutson = owrd.ActiveDocument.Tables(i).Columns.Count
sat = sat + 1
Cells(sat, 1) = satson
For j = 1 To sutson

deg1 = Replace(Trim(Trim(owrd.ActiveDocument.Tables.Item(i).Cell(satson, j).Range.Text)), Chr(13), "")
Cells(sat, j + 1) = Mid(deg1, 1, Len(deg1) - 1)

Next j
Next i
End If


odoc.Close False
owrd.Quit

Set odoc = Nothing


MsgBox "işlem tamam"

End Sub

referanslarla ilgili aşağıdaki bölümün olması gerekiyor.

Microsoft Word [COLOR="Red"]12[/COLOR].0 Object Library

 

[halit3]

Bu kod ile excelle word tabloların hepsinden veri alınıyor.

Sub tablo_word1()


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

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

yol = ActiveWorkbook.Path & "\deneme.doc"

Set docWord = objWord.Documents.Open(Filename:=yol, ReadOnly:=True)

'Set docWord = objWord.Documents.Open(Filename:=yol, Visible:=True)

sat = 1

If objWord.ActiveDocument.Tables.Count > 0 Then
For i = 1 To objWord.ActiveDocument.Tables.Count
satson = objWord.ActiveDocument.Tables(i).Rows.Count
sutson = objWord.ActiveDocument.Tables(i).Columns.Count
Cells(sat + 1, 1) = i & ".Toblo"
Cells(sat + 1, 2) = satson & ".Satır"
'objWord.ActiveDocument.Tables.Item(i).Cell(r, j).Column.Cells.Count
Cells(sat + 1, 2).Select


For r = 1 To satson
sat = sat + 1

Cells(sat, 3) = objWord.ActiveDocument.Tables(i).Rows(r).Cells.Count
'MsgBox objWord.ActiveDocument.Tables(i).Rows(r).Cells.Count

For j = 1 To objWord.ActiveDocument.Tables(i).Rows(r).Cells.Count

deg1 = Replace(Trim(Trim(objWord.ActiveDocument.Tables.Item(i).Cell(r, j).Range.Text)), Chr(13), "")
Cells(sat, j + 3) = Mid(deg1, 1, Len(deg1) - 1)
Next j

Next r

Next i
End If


docWord.Close False
objWord.Quit

Set docWord = Nothing


MsgBox "işlem tamam"

End Sub

kodun çalışması ile ilgili referanslardan aşağıdaki bölümün olması gerekiyor.

Microsoft Word [COLOR="Red"]12[/COLOR].0 Object Library

Ayrıca tablolardaki bilgileri çok hızlı bir şekilde açık olan sayfaya kopyalıyor.

Sub tablo_word8()
Cells.ClearContents

Dim objDialog, intResult
Set objDialog = CreateObject("MSComDlg.CommonDialog")
objDialog.Flags = 4
'objDialog.Filter = "DosyalarExcel Files (.doc)|*.doc"
objDialog.Filter = "Tüm Dosyalar(*.*)|*.*|Excell Files (*.xls*)|*.xls*|MSWord Files (*.doc)|*.doc|PDF Files (*.pdf)|*.pdf|Metin Files (*.txt*)|*.txt*"

objDialog.FilterIndex = 3

objDialog.InitDir = ThisWorkbook.Path
objDialog.ShowOpen

intResul = objDialog.Filename
If Len(intResul) = 0 Then
Dim Msg
Msg = "Dosya seçmediniz."
MsgBox Msg, vbInformation + vbCritical
Exit Sub
Set objDialog = Nothing

Else
yol = objDialog.Filename

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

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

Set docWord = objWord.Documents.Open(Filename:=yol, ReadOnly:=True)


objWord.ActiveDocument.Application.WindowState = wdWindowStateMinimize
'objWord.ActiveDocument.Application.WindowState = wdWindowStateNormal

sat = 2

If objWord.ActiveDocument.Tables.Count > 0 Then
For i = 1 To objWord.ActiveDocument.Tables.Count
satson = objWord.ActiveDocument.Tables(i).Rows.Count
sutson = objWord.ActiveDocument.Tables(i).Columns.Count
objWord.ActiveDocument.Tables(i).Range.Copy

ThisWorkbook.ActiveSheet.Cells(sat, 1).PasteSpecial Paste:=3
sat = sat + satson

Next i
End If

docWord.Close False
objWord.Quit

Set docWord = Nothing

End If
Set objDialog = Nothing
Range("a1").Select

MsgBox "işlem tamam"

End Sub

 

[alicimri]

Ben de biraz uğraşmıştım.
Uyarı
1- Excel'de 17 satırdaki Mahal Adı Depo olan yerin Word'de tablosu yok.
2- Alt toplamları verileri aldıktan sonra oluşturun daha sağlıklı sonuç alırsınız.

Sub tablo_word()

yol = ActiveWorkbook.Path
yol = yol & "\22C-24C.rtf"
Set owrd = CreateObject("Word.Application")
Set odoc = owrd.Documents.Open(Filename:=yol, Visible:=True)
sat = 5
For E = 1 To owrd.ActiveDocument.Tables.Count
If E Mod 2 = 1 Then
I = owrd.ActiveDocument.Tables(E).Rows(24).Cells(3)
J = owrd.ActiveDocument.Tables(E).Rows(24).Cells(4)
M = owrd.ActiveDocument.Tables(E).Rows(24).Cells(6)
Sheets("İNÖNÜ ÜN.").Range("I" & sat).Value = Left(I, Len(I) - 2)
Sheets("İNÖNÜ ÜN.").Range("J" & sat).Value = Left(J, Len(J) - 2)
Sheets("İNÖNÜ ÜN.").Range("M" & sat).Value = Left(M, Len(M) - 2)
sat = sat + 1
End If
Next
odoc.Close False
owrd.Quit
Set odoc = Nothing
End Sub