Excel'den word'e veri aktarma

YUSUF44 · 22 Eylül 2019

İyi geceler arkadaşlar.

Ekte bir excel bir de word dosyam var. Excel dosyasında Tabloyu Aç düğmesi ile açılan userform üzerinden dosyada değişiklik yapmayı vs ayarladım. O kısımda şimdilik bir talebim yok.

Talebim şöyle, ekteki word dosyasının 5. sayfasında (bu değişebilir) ÖZEL ESASLAR diye başlayan kırmızı renkli kısımların, excel dosyasındaki Katipler sayfasından alınarak örnekteki gibi doldurulması gerekiyor. Yani Katipler sayfasındaki isimleri alıp başlık olarak worde yazacak, altına numaralandırarak Katipler sayfasının J sütunundan itibaren yazılı görevleri ekleyecek. Kişinin görevleri bitince diğer personele geçecek. Son olarak da en sonraki tebligat sayfasını oluşturacak.

Yardımcı olursanız çok mutlu olurum.

halit3 · 23 Eylül 2019

Word dosyasının 5. sayfasına ait bilgileri satır satır hangi hücrelerden aldırıyorsunuz? Bunlanı bilirtiniz.
mevcut dosyanızdaki verilerle word dosyasındaki veriler farklı ben anlayamadım.

erd5334 · 23 Eylül 2019

Aktarmak istediğiniz word belgesinde yer imi ekleyip o yer imlerine de excelden ulaşıp istediğiniz değişikliği yapabilirsiniz. excel vba referanslardan da word kütüphanesini ekleyip belgenize ulaşmanız gerekiyor.

YUSUF44 · 23 Eylül 2019

halit3' Alıntı:
Word dosyasının 5. sayfasına ait bilgileri satır satır hangi hücrelerden aldırıyorsunuz? Bunlanı bilirtiniz.
mevcut dosyanızdaki verilerle word dosyasındaki veriler farklı ben anlayamadım.

İlginiz için teşekkürler.

Excel dosyasında Katipler sayfasının her satırı bir katibe ait. B, C ve D sütunlarında unvan, ad soyad ve sicil no var. Bu bilgiler her kişinin worddeki ilk satırını oluşturuyor. Sonra paragraf yapılıp E sütunları arasındaki görevli olduğu bürolar belirtiliyor. Sonra tekrar paragraf yapılıp, J sütunundan itibaren olan görevler maddeler halinde altına sıralanıyor. Örneğin excel dosyasındaki ilk katip için worddeki metin şöyle olmalı:

Zabıt Katibi Ali (1):

Genişletmek için tıkla ...

Kütüphane ve Mutemetlik Bürolarında görevlendirilmiştir.
1- Görevlendirildiği iş ve işlemlerin yanı sıra zabıt katibi …........... yokluğunda uhdesindeki iş ve işlemleri yerine getirmek.
2- Cumhuriyet Savcısı ….......... uhdesindeki soruşturma dosyalarının işlemleri ile ilgili olarak vereceği talimat doğrultusunda işlem yapmak,

3. görev olmadığı için bu kişiyle işimiz bitecek ve altına bir boşluk bırakılıp, ikinci katibe geçilecek.

İnternette bayağı araştırdım ama excelden worde bu tarz bir aktarma bulamadım maalesef. Genelde adres mektup birleştirme ile ilgili çözümler var. Ben de işin olmayacağını düşünerek raporu excelde oluşturmak için kod yazdım. Eğer burda çözüm bulunamazsa mecburen excel çözümünü kullanacağım.

YUSUF44 · 23 Eylül 2019

erd5334' Alıntı:
Aktarmak istediğiniz word belgesinde yer imi ekleyip o yer imlerine de excelden ulaşıp istediğiniz değişikliği yapabilirsiniz. excel vba referanslardan da word kütüphanesini ekleyip belgenize ulaşmanız gerekiyor.

İlginiz için teşekkürler.

Maalesef bu belirttiğinizi nasıl yapacağımı anlayamadım. Daha ayrıntılı anlatır mısınız?

erd5334 · 23 Eylül 2019

YUSUF44' Alıntı:
İlginiz için teşekkürler.

Maalesef bu belirttiğinizi nasıl yapacağımı anlayamadım. Daha ayrıntılı anlatır mısınız?

hocam link vermek ne kadar doğru bilmiyorum ama aşağıdaki siteyi inceleyin. olmadı tekrar yardımcı olurum.

https://www.wiseowl.co.uk/blog/s199/word-bookmarks.htm

halit3 · 23 Eylül 2019

Yukarıdaki mesajımda da yazmıştım
Örnek dosyanızdaki katipler sayfasındaki verilerle word dosyası beşinci sayfa uyumlu değil
katipler sayfasında farklı bir şeyler yazıyor word sayfasında farklı
onun için bire bir veriler aynı olsun ki nasıl olacağına bakalım.
kırmızı renkli yazılar dosyanın hangi hücresinden geliyor.

YUSUF44 · 23 Eylül 2019

Halit Bey ne demek istediğinizi çok iyi anladım. Excel dosyasındaki Görev1 sütunu (yani J sütunu) katiplerin ilk görevi, Görev2/K sütunu 2. görevi .... şeklinde. Raporu worde aktar dediğimde worddeki o kırmızı bölüm tamamen iptal olacak ve excel dosyasındaki verilere göre yenisi oluşacak. Kişiler ve görevler değişebilir. Paylaştığınız resimlerde J2 hücresindeki veri zabıt katibi Ali'nin altında 1- ile başlayan kısma gelecek. J sütunundan itibaren sağa doğru kaç görev varsa altta madde madde sıralanacak.

Worddeki örneğe uygun excel dosyası ektedir.

Haluk · 23 Eylül 2019

@YUSUF44 ; VBA ile bir sürü alternatif üretilebilir.

Bunlardan bir tanesi aşağıdadır..... Kod, Excel dosyasının olduğu yerde "Katipler.doc" adında bir dosya oluşturuyor.

Kod:

Sub Test()
    'Haluk - 23/09/2019
    'sa4truss@gmail.com
    '
    Dim FSO As Object
    Dim MySheet As Worksheet
    Dim LastRow As Integer, LastColumn As Byte, i As Byte, j As Byte, x As Byte
    Dim MyFile As String, WordDoc As Object
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Set MySheet = Sheets("Katipler")
    
    LastRow = MySheet.Cells(MySheet.Rows.Count, "A").End(xlUp).Row
    LastColumn = MySheet.Cells(1, MySheet.Columns.Count).End(xlToLeft).Column
    
    MyFile = ThisWorkbook.Path & "\Katipler.doc"
    
    Set WordDoc = FSO.OpenTextFile(MyFile, 2, True)
    
    For i = 2 To LastRow
        WordDoc.WriteLine Range("B" & i) & " " & Range("C" & i) & vbCrLf
        GorevYerleri = Join(Application.Transpose(Application.Transpose(Range("E" & i & ":" & "I" & i))), ",")
        x = 0
        WordDoc.WriteLine Left(GorevYerleri, Len(GorevYerleri) - 1) & " bürosunda görevlendirilmiştir."
        For j = 10 To LastColumn
            If MySheet.Cells(i, j) <> "" Then
                x = x + 1
                MyVal = x & "- " & MySheet.Cells(i, j)
                WordDoc.WriteLine MyVal
            End If
        Next
        WordDoc.WriteLine x + 1 & "- " & "Yazı İşleri Müdürü'nün vereceği diğer işleri yapmakla görevlidir."
        WordDoc.WriteLine vbCrLf
    Next
    
    WordDoc.Close
    
    Set WordDoc = Nothing
    Set MySheet = Nothing
    Set FSO = Nothing
End Sub

.

YUSUF44 · 23 Eylül 2019

Haluk Bey çok teşekkürler.
Çözümünüze ek olarak word dosyasında biçim ayarlamayı ve oluşan metni mevcut bir dosyanın belirli bir yerine eklemeyi de yapabilir miyiz?

erd5334 · 23 Eylül 2019

YUSUF44' Alıntı:
Halit Bey ne demek istediğinizi çok iyi anladım. Excel dosyasındaki Görev1 sütunu (yani J sütunu) katiplerin ilk görevi, Görev2/K sütunu 2. görevi .... şeklinde. Raporu worde aktar dediğimde worddeki o kırmızı bölüm tamamen iptal olacak ve excel dosyasındaki verilere göre yenisi oluşacak. Kişiler ve görevler değişebilir. Paylaştığınız resimlerde J2 hücresindeki veri zabıt katibi Ali'nin altında 1- ile başlayan kısma gelecek. J sütunundan itibaren sağa doğru kaç görev varsa altta madde madde sıralanacak.

Worddeki örneğe uygun excel dosyası ektedir.

hocam bunu c# ta yapsak uygun mudur?

YUSUF44 · 23 Eylül 2019

erd5334' Alıntı:
hocam bunu c# ta yapsak uygun mudur?

Hiç denemedim, nasıldır bilmiyorum. Herhangi bir bilgisayardaki excel ile çalışabilecekse neden olmasın? Öğrenmek isterim açıkçası.

halit3 · 23 Eylül 2019

Bu kodu bir dene 5. sayfa istenilen gibi oluyormu

halit3 · 23 Eylül 2019

Makroları çalıştırdığın dosyanın yanına bu dosyayı rar dan çıkart koy ve eklediğim makroyu çalıştır.

son sayfa hariç verilerin gelmesi lazım.

YUSUF44 · 23 Eylül 2019

Teşekkürler Halit Bey. Bilgisayara ancak yarın bakabilirim. Siz yaptıysanız olmuştur eminim.

Haluk · 23 Eylül 2019

@YUSUF44; Alternatif olarak aşağıdaki kodu deneyebilirsiniz....

Bu kodla, seçilen Word dosyasının içeriğinde herhangibir sayfada "ÖZEL ESASLAR:" metni bulunduktan sonra, Excel dosyasından alınan veriler biçimlendirilerek bu metnin altındaki satırlarına yazılmaktadır. Yani, Excel'den alınan verilerin Word dosyasında yerleştirileceği bölüm buna göre belirlenmektedir.

Kod:

Sub Test3()
    'Haluk -23/09/2019
    'sa4truss@gmail.com
    '
    Dim MySheet As Worksheet
    Dim LastRow As Integer, LastColumn As Byte, i As Byte, j As Byte, x As Byte
    Dim MyFile As String, objWord As Object, objDoc As Object

    Const wdGoToLine = 3
    Const wdGoToNext = 2
    Const wdColorRed = 255
    Const wdColorBlack = 0
    Const wdUnderlineSingle = 1
    Const wdUnderlineNone = 0

    Set MySheet = Sheets("Katipler")

    LastRow = MySheet.Cells(MySheet.Rows.Count, "A").End(xlUp).Row
    LastColumn = MySheet.Cells(1, MySheet.Columns.Count).End(xlToLeft).Column

    With Application.FileDialog(msoFileDialogFilePicker)
       .AllowMultiSelect = False
       .Filters.Add "Word Dosyaları", "*.docx", 1
       If .Show = True Then
        MyFile = .SelectedItems.Item(1)
       Else
        Exit Sub
       End If
    End With

    Set objWord = CreateObject("Word.Application")
    Set objDoc = objWord.Documents.Open(MyFile)

    With objWord.Selection.Find
        .ClearFormatting
        .Text = "ÖZEL ESASLAR:"
    End With

    If objWord.Selection.Find.Execute Then
        objWord.Selection.Select
        objWord.Selection.Goto What:=wdGoToLine, Which:=wdGoToNext, Count:=2
    End If

    For i = 2 To LastRow
        Set objSelection = objWord.Selection
        objSelection.TypeText vbCrLf
        objSelection.ClearFormatting
        objSelection.Font.Bold = True
        objSelection.Font.Color = wdColorRed
        objSelection.Font.Underline = wdUnderlineSingle
        strTemp = Range("B" & i) & " " & Range("C" & i)
        objSelection.TypeText (strTemp & vbCrLf)
    
        objSelection.ClearFormatting
        objSelection.Font.Bold = False
        objSelection.Font.Underline = wdUnderlineNone
        objSelection.Font.Color = wdColorBlack
        GorevYerleri = Join(Application.Transpose(Application.Transpose(Range("E" & i & ":" & "I" & i))), ",")
        strTemp = Left(GorevYerleri, Len(GorevYerleri) - 1) & " bürosunda görevlendirilmiştir."
        objSelection.TypeText (strTemp & vbCrLf)
    
        x = 0
        For j = 10 To LastColumn
            If MySheet.Cells(i, j) <> "" Then
                x = x + 1
                MyVal = x & "- " & MySheet.Cells(i, j)
                objSelection.TypeText (MyVal & vbCrLf)
            End If
        Next
        strTemp = x + 1 & "- " & "Yazı İşleri Müdürü'nün vereceği diğer işleri yapmakla görevlidir."
        objSelection.TypeText (strTemp & vbCrLf)
    Next

    objDoc.SaveAs MyFile
    objDoc.Close
    objWord.Quit
    Set objDoc = Nothing
    Set objWord = Nothing
End Sub

.

YUSUF44 · 24 Eylül 2019

erd5334' Alıntı:
hocam link vermek ne kadar doğru bilmiyorum ama aşağıdaki siteyi inceleyin. olmadı tekrar yardımcı olurum.

https://www.wiseowl.co.uk/blog/s199/word-bookmarks.htm

Teşekkürler. Ancak bana pek uymayan bir çözüm gibi. Exceldeki her hücre için ayrı bookmark kullanmam gerekecek.

YUSUF44 · 24 Eylül 2019

halit3' Alıntı:

Bu kodu bir dene 5. sayfa istenilen gibi oluyormu

'referanslar
'Microsoft Word 12.0 Object Library
'eklenmeli

Kod:

Sub Makro33()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

'Dosya_Adı = ActiveWorkbook.Name
'Sayfa_Adı = ActiveSheet.Name


Dim objWord As Word.Application
Dim myDoc As Word.Document

Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set myDoc = objWord.Documents.Add(DocumentType:=wdNewBlankDocument)
'Set myDoc = objWord.Documents.Add ' create a new document
With myDoc
.Content.InsertParagraphAfter

With objWord.ActiveDocument.PageSetup
.LeftMargin = 50 'sol
.RightMargin = 50 'sağ
'.TopMargin = 50 'üst
'.BottomMargin = 20 '20 ' alt
End With
End With

sayf1 = "Katipler"
sat = 0

sat = sat + 1

objWord.ActiveDocument.Paragraphs(sat).Range.InsertParagraphAfter
objWord.ActiveDocument.Paragraphs(sat).Range.InsertBefore "        ÖZEL ESASLAR:"

objWord.ActiveDocument.Range(Start:=8, End:=21).Font.Underline = wdUnderlineSingle

sat = sat + 1
objWord.ActiveDocument.Paragraphs(sat).Range.InsertParagraphAfter
objWord.ActiveDocument.Paragraphs(sat).Range.InsertBefore ""

For i = 2 To Worksheets(sayf1).Cells(Rows.Count, "A").End(3).Row

sat = sat + 1
objWord.ActiveDocument.Paragraphs(sat).Range.InsertParagraphAfter
objWord.ActiveDocument.Paragraphs(sat).Range.InsertBefore ""

sat = sat + 1

Deg = "        " & Worksheets(sayf1).Cells(i, 2) & " " & Worksheets(sayf1).Cells(i, 3) & " (" & Worksheets(sayf1).Cells(i, 4) & ")"


objWord.ActiveDocument.Paragraphs(sat).Range.InsertParagraphAfter
objWord.ActiveDocument.Paragraphs(sat).Range.InsertBefore Deg

ilk = objWord.ActiveDocument.Paragraphs(sat).Range.Start
objWord.ActiveDocument.Range(Start:=8 + ilk, End:=ilk + Len(Deg)).Font.Underline = wdUnderlineSingle


veri1 = ""
say1 = 0
For j = 5 To 9 'Step -1
If Worksheets(sayf1).Cells(i, j) <> "" Then
say1 = say1 + 1
If say1 = 1 Then
veri1 = Worksheets(sayf1).Cells(i, j)
Else
veri1 = veri1 & ", " & Worksheets(sayf1).Cells(i, j)
End If

If say1 = 1 Then
ekle1 = " Bürosunda görevlendirilmiştir"
Else
ekle1 = " Bürolarında görevlendirilmiştir"
End If
'GoTo atla
End If
Next j

sat = sat + 1
objWord.ActiveDocument.Paragraphs(sat).Range.InsertParagraphAfter
objWord.ActiveDocument.Paragraphs(sat).Range.InsertBefore "        " & veri1 & ekle1

veri2 = ""
say2 = 0
For j = 28 To 10 Step -1
If Worksheets(sayf1).Cells(i, j) <> "" Then

say2 = j

GoTo atla
End If
Next j

atla:

say3 = 0
For j = 10 To say2
say3 = say3 + 1
sat = sat + 1
objWord.ActiveDocument.Paragraphs(sat).Range.InsertParagraphAfter
objWord.ActiveDocument.Paragraphs(sat).Range.InsertBefore "        " & say3 & "- " & Worksheets(sayf1).Cells(i, j)
Next j
'objWord.Selection.TypeParagraph
sat = sat + 1
objWord.ActiveDocument.Paragraphs(sat).Range.InsertParagraphAfter
objWord.ActiveDocument.Paragraphs(sat).Range.InsertBefore ""

Next i

ssay1 = CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).Files.Count
objWord.ActiveDocument.SaveAs ThisWorkbook.Path & "\Word " & ssay1 + 1 ' & ".doc"

'myDoc.Close
'objWord.Quit

Application.DisplayAlerts = False
MsgBox "işlem tamam"
objWord.Documents(myDoc.Name).Activate
Set objWord = Nothing


End Sub

Teşekkürler. Referans bölümünde object library 12 değil de 16 yüklü (işaretli) görünüyor. Ancak makroyu çalıştırdığımda
Dim objWord As Word.Application
kısmında User defined type not defined hatası veriyor.
Beceremedim herhalde.

YUSUF44 · 24 Eylül 2019

halit3' Alıntı:

Makroları çalıştırdığın dosyanın yanına bu dosyayı rar dan çıkart koy ve eklediğim makroyu çalıştır.

son sayfa hariç verilerin gelmesi lazım.

Kod:

Sub Makro44()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Dosya_Adı = ActiveWorkbook.Name
'Sayfa_Adı = ActiveSheet.Name
yol = ThisWorkbook.Path & "\Katip"

Dim objWord As Word.Application
Dim myDoc As Word.Document

Set objWord = CreateObject("Word.Application")
objWord.Visible = True
'Set myDoc = objWord.Documents.Add(DocumentType:=wdNewBlankDocument)
'Set myDoc = objWord.Documents.Add ' create a new document
Set myDoc = objWord.Documents.Open(Filename:=yol, ReadOnly:=True)

sayf1 = "Katipler"
sat = 0
'sat = sat + 1

sat = myDoc.Range.Paragraphs.Count


objWord.ActiveDocument.Paragraphs(sat).Range.InsertParagraphAfter
objWord.ActiveDocument.Paragraphs(sat).Range.InsertBefore "        ÖZEL ESASLAR:"

ilk1 = objWord.ActiveDocument.Paragraphs(sat).Range.Start

objWord.ActiveDocument.Range(Start:=8 + ilk1, End:=ilk1 + 21).Font.Underline = wdUnderlineSingle

sat = sat + 1
objWord.ActiveDocument.Paragraphs(sat).Range.InsertParagraphAfter
objWord.ActiveDocument.Paragraphs(sat).Range.InsertBefore ""

For i = 2 To Worksheets(sayf1).Cells(Rows.Count, "A").End(3).Row

sat = sat + 1
objWord.ActiveDocument.Paragraphs(sat).Range.InsertParagraphAfter
objWord.ActiveDocument.Paragraphs(sat).Range.InsertBefore ""

sat = sat + 1

Deg2 = "        " & Worksheets(sayf1).Cells(i, 2) & " " & Worksheets(sayf1).Cells(i, 3) & " (" & Worksheets(sayf1).Cells(i, 4) & ")"

objWord.ActiveDocument.Paragraphs(sat).Range.InsertParagraphAfter
objWord.ActiveDocument.Paragraphs(sat).Range.InsertBefore Deg2

ilk2 = objWord.ActiveDocument.Paragraphs(sat).Range.Start
objWord.ActiveDocument.Range(Start:=8 + ilk2, End:=ilk2 + Len(Deg2)).Font.Underline = wdUnderlineSingle


veri1 = ""
say1 = 0
For j = 5 To 9 'Step -1
If Worksheets(sayf1).Cells(i, j) <> "" Then
say1 = say1 + 1
If say1 = 1 Then
veri1 = Worksheets(sayf1).Cells(i, j)
Else
veri1 = veri1 & ", " & Worksheets(sayf1).Cells(i, j)
End If

If say1 = 1 Then
ekle1 = " Bürosunda görevlendirilmiştir"
Else
ekle1 = " Bürolarında görevlendirilmiştir"
End If
'GoTo atla
End If
Next j

sat = sat + 1
objWord.ActiveDocument.Paragraphs(sat).Range.InsertParagraphAfter
objWord.ActiveDocument.Paragraphs(sat).Range.InsertBefore "        " & veri1 & ekle1

veri2 = ""
say2 = 0
For j = 28 To 10 Step -1
If Worksheets(sayf1).Cells(i, j) <> "" Then

say2 = j

GoTo atla
End If
Next j

atla:

say3 = 0
For j = 10 To say2
say3 = say3 + 1
sat = sat + 1
objWord.ActiveDocument.Paragraphs(sat).Range.InsertParagraphAfter
objWord.ActiveDocument.Paragraphs(sat).Range.InsertBefore "        " & say3 & "- " & Worksheets(sayf1).Cells(i, j)
Next j
sat = sat + 1
objWord.ActiveDocument.Paragraphs(sat).Range.InsertParagraphAfter
objWord.ActiveDocument.Paragraphs(sat).Range.InsertBefore ""

Next i

ssay1 = CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).Files.Count
objWord.ActiveDocument.SaveAs ThisWorkbook.Path & "\Word " & ssay1 + 1 ' & ".doc"

'myDoc.Close
'objWord.Quit
Application.DisplayAlerts = False
MsgBox "işlem tamam"
objWord.Documents(myDoc.Name).Activate
Set objWord = Nothing


End Sub

Bunda da aynı tanımlama hatasını verdi maalesef.

erd5334 · 24 Eylül 2019

YUSUF44' Alıntı:
Hiç denemedim, nasıldır bilmiyorum. Herhangi bir bilgisayardaki excel ile çalışabilecekse neden olmasın? Öğrenmek isterim açıkçası.

hocam şöyle düşünün .exe dosyası olacak bu veritabanından(sqlite,acess) bilgileri çekecek. sonra istediğiniz bilgileri wordde istediğiniz yere yazacak. wordde matbu bir evrağınız olacak onun üzerine bilgileri yazıp masaüstüne yeni bir dosya olarak farklı kaydedecek.

Excel'den word'e veri aktarma

YUSUF44

Destek Ekibi

Ekli dosyalar

halit3

Uzman

erd5334

YUSUF44

Destek Ekibi

YUSUF44

Destek Ekibi

erd5334

halit3

Uzman

YUSUF44

Destek Ekibi

Ekli dosyalar

Haluk

𐱅𐰇𐰼𐰚

YUSUF44

Destek Ekibi

erd5334

YUSUF44

Destek Ekibi

halit3

Uzman

halit3

Uzman

YUSUF44

Destek Ekibi

Haluk

𐱅𐰇𐰼𐰚

YUSUF44

Destek Ekibi

YUSUF44

Destek Ekibi

YUSUF44

Destek Ekibi

erd5334