Ms.Excel üzerinden tablo yapılması

[1903emre34@gmail.com]

Merhaba,

A sütundaki, verileri yeni word dosyasında (ekte belge1 dosyasında yer alan aynı formatta) olacak şekilde nasıl kod oluşturabiliriz?

http://www.dosya.tc/server9/t9p4p1/tablo_1.zip.html

 

[halit3]

referanslar bölümünde bu olmalı

Microsoft Word 12.0 Object Library

kod:

Sub deneme()

Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")
Dim Say

yol = ThisWorkbook.Path & "\"

say1 = Cells(Rows.Count, "a").End(3).Row - 1

Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Add
wrdApp.Visible = True

'wrdDoc.Content.InsertParagraphAfter
With wrdApp.ActiveDocument

With .PageSetup
'.LeftMargin = 15 '50 'sol
'.RightMargin = 10 '50 'sağ
'.TopMargin = 10 'üst
'.BottomMargin = 5 '20 ' alt
End With

Set myRange = wrdApp.ActiveDocument.Range(0, 0)
.Tables.Add Range:=myRange, NumRows:=say1, NumColumns:=3

With .Tables(1)
If .Style <> "Tablo Kılavuzu" Then
.Style = "Tablo Kılavuzu"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = True
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = True
End With


wrdApp.Selection.Tables(1).Columns(1).SetWidth ColumnWidth:=30, RulerStyle:=wdAdjustNone
wrdApp.Selection.Tables(1).Columns(2).SetWidth ColumnWidth:=342, RulerStyle:=wdAdjustNone

wrdApp.Selection.Tables(1).Columns(3).SetWidth ColumnWidth:=107, RulerStyle:=wdAdjustNone

For i = 3 To Cells(Rows.Count, "a").End(3).Row

Say = 0

hucre = Cells(i, 1)
For j = 1 To Len(hucre)
If IsNumeric(Mid(hucre, j, 1)) = True Then
Say = j
Exit For
End If
Next j

.Tables.Item(1).Cell(i - 1, 1).Range = i - 2
.Tables.Item(1).Cell(i - 1, 2).Range = Mid(hucre, 1, j - 1)
.Tables.Item(1).Cell(i - 1, 3).Range = Mid(hucre, j, Len(hucre))
.Tables.Item(1).Cell(i - 1, 3).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
Next i
End With

son1 = CreateObject("Scripting.FileSystemObject").getfolder(ThisWorkbook.Path).Files.Count + 1
dosya_adi = ThisWorkbook.Path & "\" & "word dosya" & son1 & ".doc"
wrdDoc.SaveAs dosya_adi
wrdDoc.Close
wrdApp.Quit
'wrdApp.Documents(wrdDoc.Name).Activate
If Not (wrdApp Is Nothing) Then
Set wrdApp = Nothing
End If

MsgBox "işlem tamam"

End Sub

 

[1903emre34@gmail.com]

Teşekkür ederim, Halit bey

 

[halit3]

kod:

Sub deneme2()

Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")
Dim Say

yol = ThisWorkbook.Path & "\"

say1 = Cells(Rows.Count, "a").End(3).Row - 1

Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Add
wrdApp.Visible = True

'wrdDoc.Content.InsertParagraphAfter
With wrdApp.ActiveDocument

With .PageSetup
'.LeftMargin = 15 '50 'sol
'.RightMargin = 10 '50 'sağ
'.TopMargin = 10 'üst
'.BottomMargin = 5 '20 ' alt
End With

Set myRange = wrdApp.ActiveDocument.Range(0, 0)
.Tables.Add Range:=myRange, NumRows:=say1, NumColumns:=3

With .Tables(1)
If .Style <> "Tablo Kılavuzu" Then
.Style = "Tablo Kılavuzu"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = True
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = True
End With


wrdApp.Selection.Tables(1).Columns(1).SetWidth ColumnWidth:=30, RulerStyle:=wdAdjustNone
wrdApp.Selection.Tables(1).Columns(2).SetWidth ColumnWidth:=342, RulerStyle:=wdAdjustNone
wrdApp.Selection.Tables(1).Columns(3).SetWidth ColumnWidth:=107, RulerStyle:=wdAdjustNone

For i = 3 To Cells(Rows.Count, "a").End(3).Row

Say = 0

hucre = Cells(i, 1)
For j = 1 To Len(hucre)
If Mid(StrReverse(hucre), j, 1) <> "." Then
If Mid(StrReverse(hucre), j, 1) <> "," Then

If IsNumeric(Mid(StrReverse(hucre), j, 1)) = False Then
Say = j
Exit For
End If
End If
End If
Next j


.Tables.Item(1).Cell(i - 1, 1).Range = i - 2
.Tables.Item(1).Cell(i - 1, 2).Range = Mid(hucre, 1, Len(hucre) - Say)
.Tables.Item(1).Cell(i - 1, 3).Range = Mid(hucre, Len(hucre) - Say + 2, Len(hucre))
.Tables.Item(1).Cell(i - 1, 3).Range.ParagraphFormat.Alignment = 2

Next i
End With

son1 = CreateObject("Scripting.FileSystemObject").getfolder(ThisWorkbook.Path).Files.Count + 1
dosya_adi = ThisWorkbook.Path & "\" & "word dosya" & son1 & ".doc"
wrdDoc.SaveAs dosya_adi
wrdDoc.Close
wrdApp.Quit
'wrdApp.Documents(wrdDoc.Name).Activate
If Not (wrdApp Is Nothing) Then
Set wrdApp = Nothing
End If

MsgBox "işlem tamam"

End Sub