Belge içeriğini Excel dosyasına aktarma
Merhaba, bu uygulamamızda sizlerle birlikle bir word belgesindeki tablo içeriğini yeni oluşturucağımız bir Excel dosyasının ilk çalışma sayfasına aktarmaya çalışacağız. Fazla vakit kaybetmeden ve gereksiz bilgiler vermeden isterseniz yapacaklarımızı anlatmaya başlayalım.
-
Her daim olduğu gibi evvela yeni bir belge açıyor ve makro güvenlik düzeyini düşük olarak ayarlıyoruz. Nasıl yapılacağını hatırlamak için yine her zaman olduğu gibi bu bağlantıyı kullanabilirsiniz.
-
Sonrasında aşağıda verilen ekran çıktısını belgenize uyguluyorsunuz. Burada 3 adet CommandButton nesnesi yer almaktadır, bunlardan biri trigonometrik fonksiyonlardan biri olan Sinus fonksiyonu için 0-360 derece aralığında 10 ar derece ilerleyerek sonuçları listelemektedir. Bir diğer butonumuz etiketinden de anlaşılacağı üzere elde edilen tablo verilerini Excel dosyasına aktarmak içindir ve son butonumuz ise belgedeki değişiklikleri kaydetmeden kapatmak içindir. Lütfen CommandButton nesnelerinin name özelliklerini aşağıdaki ekran çıktısında kırmızı ile belirtilen string değerlere ayarlayınız.
-
Tasarımı tamamladıktan sonra ALt+F11 ile ekrana gelen VBA kod düzenleyicisi ekranına aşağıda verilen kodları yazıyoruz. Sonrasında belgemizi kapatıp yeniden açıyor ve yazdıklarımızı test ediyoruz. Size şimdiden kolay gelsin. Kod yazmaktan hoşlanmayan arkadaşlar doğrudan kaynak dosyayı indirerek deneyebilirler. Umarım bir faydası olmuştur.
Esen kalın...
Kaynak Kodlar
'Tanimlanmayan değişkenlerin kullanılmasına izin verilmiyor.
Option Explicit
Private Sub btnCikis_Click()
'1. Acik belgeyi kaydetmeden cik
Application.Quit wdDoNotSaveChanges
'2. Acik belgeyi kaydet ve cik
' Application.Quit wdSaveChanges
End Sub
Private Function karakterAyikla(deger As String) As Double
'*********************************************************************************
'Kodlayan : Bilal SERT
'Amaç : Verilerin içindeki VbCr satir sonu karakterini temizlemek
'Tarih-Saat : 18.12.2013 - 11:53
'Giriş/Çıkış : deger- işlenecek veri
'Değiştiren :
'Tarih/Saat :
'Gerekçe :
'*********************************************************************************
Dim sonuc As String, sayac As Integer
sonuc = ""
For sayac = 1 To Len(deger)
If Asc(Mid(deger, sayac, 1)) <> 13 And Asc(Mid(deger, sayac, 1)) <> 7 _
Then sonuc = sonuc & Trim(Mid(deger, sayac, 1))
' MsgBox Mid(deger, sayac, 1) & " = " & Asc(Mid(deger, sayac, 1))
Next
karakterAyikla = CDbl(sonuc)
End Function
Private Sub btnDisaAktar_Click()
Dim uygulama As Excel.Application, dosya As Excel.Workbook, sayfa As Excel.Worksheet
Dim dosSis As Object, satir As Integer
Dim hedef As String
If ThisDocument.Tables.Count <> 0 Then
''*********************************************************************************
'Verilerin aktarilacagi bir klasor olusturuluyor
hedef = "c:\WordToExcel"
Set dosSis = CreateObject("Scripting.FileSystemObject")
With dosSis
If .FolderExists(hedef) Then
On Error GoTo hata
.DeleteFolder hedef, True
End If
On Error GoTo hata
.CreateFolder hedef
End With
Set dosSis = Nothing
'**********************************************************************************
On Error GoTo hata
Set uygulama = New Excel.Application
On Error GoTo hata
Set dosya = uygulama.Workbooks.Add
Set sayfa = dosya.Sheets(1)
'Word tablosundaki veriler Excel calisma sayfasina aktariliyor
With ThisDocument.Tables(1)
If .Rows.Count > 0 Then
'sutun basliklari aktariliyor
sayfa.Cells(1, 1) = Left(.Cell(1, 1).Range.Text, Len(.Cell(1, 1).Range.Text) - 1)
sayfa.Cells(1, 2) = Left(.Cell(1, 2).Range.Text, Len(.Cell(1, 2).Range.Text) - 1)
sayfa.Cells(1, 3) = Left(.Cell(1, 3).Range.Text, Len(.Cell(1, 3).Range.Text) - 1)
'degerler aktariliyor
For satir = 2 To .Rows.Count
sayfa.Cells(satir, 1) = karakterAyikla(.Cell(satir, 1).Range.Text)
sayfa.Cells(satir, 2) = karakterAyikla(.Cell(satir, 2).Range.Text)
sayfa.Cells(satir, 3) = karakterAyikla(.Cell(satir, 3).Range.Text)
Next
End If
End With
'Dosya kaydediliyor
dosya.SaveAs hedef & Trim("\wordToExcel.xls")
'Dosya kapatiliyor
dosya.Close SaveChanges:=True
'Excel uygulamasi sonlandiriliyor
uygulama.Quit
'Nesnelerin bellek alanlari bosaltiliyor.
Set dosya = Nothing
Set uygulama = Nothing
Set sayfa = Nothing
On Error GoTo hata
Shell "c:\windows\explorer.exe" & " " & hedef, vbMaximizedFocus
Else
MsgBox "Şu an belgenizde veri aktarımı yapılacak tablo yok", _
vbInformation + vbOKOnly, "Dikkat !"
End If
Exit Sub
hata:
MsgBox Err.Description, vbCritical + vbOKOnly, "Hata olustu"
End Sub
Private Sub btnSinusFonksiyonu_Click()
Dim tablo As Table, satir, derece As Integer
With ThisDocument
'Sayfada ikinci paragraf varsa islem yap
'Ilk paragrafta denetimler bulunmaktadır.
If Paragraphs.Count > 1 Then
'daha once yapilan bir tablolar varsa sirayla siliniyor.
If Tables.Count > 0 Then
For satir = 1 To .Tables.Count
On Error Resume Next
.Tables(satir).Delete
Next
End If
'3 sutun 36 satir yeni tablo ekleniyor.
Set tablo = .Tables.Add(.Paragraphs(2).Range, 37, 3)
'tablo genisligi ayarlaniyor.
tablo.PreferredWidth = 200
'tabloya kenarliklar veriliyor
tablo.Borders.InsideLineStyle = wdLineStyleSingle
tablo.Borders.OutsideLineStyle = wdLineStyleSingle
'tablonun sutun etiketleri giriliyor.
tablo.Cell(1, 1).Range.Text = "DERECE"
tablo.Cell(1, 2).Range.Text = "RADYAN"
tablo.Cell(1, 3).Range.Text = "SİNUS"
For satir = 2 To 37
derece = (satir - 1) * 10
tablo.Cell(satir, 1).Range.Text = derece
'Radyan sutunu kirmizi renkle yazdiriliyor
tablo.Cell(satir, 2).Range.Font.ColorIndex = wdRed
tablo.Cell(satir, 2).Range.Text = Round(derece * 3.14 / 180, 2)
'sinus sutunu mavi renkle yazdiriliyor
tablo.Cell(satir, 3).Range.Font.ColorIndex = wdBlue
tablo.Cell(satir, 3).Range.Text = Round(Sin(derece * 3.14 / 180), 2)
Next
'Set tablo = Nothing
End If
End With
End Sub
Private Sub Document_Open()
If ThisDocument.Tables.Count <> 0 Then
While ThisDocument.Tables.Count <> 0
On Error Resume Next
ThisDocument.Tables(ThisDocument.Tables.Count).Delete
Wend
End If
End Sub
Faydalı olması dileğiyle