Excel'den word'e veri aktarma

halit3 · 24 Eylül 2019

Dosyaları rardan çıkart aynı dizinde yan yana olsun kodu çalıştır.
sizin dosyanızdan 4 sayfalık bölümü aldım ve diğer sayfaları kendisi oluşturuyor.
benim bilgisayarımda oluşan dosya Word 6.doc bu

YUSUF44 · 24 Eylül 2019

Haluk' Alıntı:

@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

.

Teşekkürler. Ancak maalesef işlem tamamlanmıyor. "Excel başka bir ugulamanın OLE eylemini tamamlamasını bekliyor" şeklinde hata veriyor. Tamam denince 10 saniye bekleyip tekrar aynı hatayı veriyor. Makro sonlanmıyor. Pause/break vs işe yaramıyor. Görev yöneticisinden işlem sonlandırmak zorunda kaldım.

YUSUF44 · 24 Eylül 2019

erd5334' Alıntı:
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.

Anladım. Biraz zahmetli gibi görünüyor. Vaktinizi bununla almak istemem. Teşekkürler.

YUSUF44 · 24 Eylül 2019

halit3' Alıntı:
Dosyaları rardan çıkart aynı dizinde yan yana olsun kodu çalıştır.
sizin dosyanızdan 4 sayfalık bölümü aldım ve diğer sayfaları kendisi oluşturuyor.
benim bilgisayarımda oluşan dosya Word 6.doc bu

Teşekkürler.

Makroyu çalıştırdığımda "runtime error 4065, bu yöntem ve özellik kullanılamaz. Çünkü bu komut okuma için kullanılamaz" şeklinde uyarı verip "
objWord.ActiveDocument.Paragraphs(sat).Range.InsertParagraphAfter" satırını işaretliyor. Makroyu sizin gönderdiğiniz dosyada çalıştırdım.

YUSUF44 · 24 Eylül 2019

Haluk' Alıntı:

@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

.

Şimdi word dosyasını farklı kaydedip o dosya üzerinde denedim, oldu. Teşekkürler. İlk denemede yanlış bir şeyler yaptım demek ki.

halit3 · 24 Eylül 2019

referanslardan
Microsoft Word xx.0 Object Library
bu olmalı birde

güvenlik merkezinde
visual basic project erişimine güven
seçeneği işaretli olmali

YUSUF44 · 24 Eylül 2019

Halit Bey, ilginiz için çok teşekkür ederim, ancak maalesef hata vermeye devam ediyor. "Bu yöntem kullanılamaz, çünkü okuma için kullanılamaz" şeklinde.

Haluk Bey'in hazırladığı kodlar işimi görüyor. Dosyamın son haline uyarladım ve bazı değişiklikler, biraz da düzeltme yaptım. Şu anda istediğime en yakın çözümü Haluk Bey sayesinde hazırladım.

halit3 · 24 Eylül 2019

21. mesajımda Word 6.doc dosyasını yazdığım kod ile oluşturdum.
sizi sorlamak istemem bu haliylede cevabı sonlandırabilirim ama isterseniz
teamwier ile bağlanabiliriz
sorun ofis 2016 dan kaynaklanıyor galiba başka bilgisayarlarda denedinizmi?

YUSUF44 · 24 Eylül 2019

Haluk' Alıntı:

@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

.

Haluk Bey, bu kodları dosyada yaptığım bazı değişikliklere göre değiştirdim ve kendime uygun hale getirdim. Çok teşekkür ederim, çok güzel çalışıyor.

Yapamadığım 2 şey kaldı, görevleri sıralarken madde imlerini koyulaştıramadım ve metni iki yana yasla özelliğini yapamadım.

Kendim excel dosyası üzerinde bir çözüm bulmuştum. Orda madde imini koyulaştırmak için

s4.Range("A" & yenigorev & "

" & yenigorev).Characters(Start:=1, Length:=numara).Font.Bold = True

kodunu kullanmıştım. Sizin kodlarınızda ilgili bölümü

myvval.Characters(Start:=1, Length:=3).Font.Bold = True

şeklinde düzenledim ama hata verdi.

Paragraf hizalama için de wordde makro kaydet yoluyla aşağıdaki kodu bulmuştum:

Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify

Bunu sizin kodunuzda

objSelection.ParagraphFormat.Alignment = wdAlignParagraphJustify

olarak değiştirdim ama bu komut çalışmıyor. Rapor sola dayalı olarak hazırlanıyor ama hata vermiyor.

Dosyaların son halini gönderiyorum:

YUSUF44 · 24 Eylül 2019

halit3' Alıntı:
21. mesajımda Word 6.doc dosyasını yazdığım kod ile oluşturdum.
sizi sorlamak istemem bu haliylede cevabı sonlandırabilirim ama isterseniz
teamwier ile bağlanabiliriz
sorun ofis 2016 dan kaynaklanıyor galiba başka bilgisayarlarda denedinizmi?

Halit Bey, bu dosyayı ben kullanmayacağımdan, genellikle makro konusunda hiç fikri olmayan arkadaşlar kullanacağından sonlandırmamız daha iyi olur diye düşünüyorum. İlginiz için teşekkür eder, vaktinizi aldığım için özür dilerim.

Haluk · 24 Eylül 2019

@YUSUF44 , bahsettiğiniz konular için aşağıdaki Test4 isimli makroyu deneyebilirsiniz.

Kod:

Sub Test4()
    'Haluk - 24/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
    Const wdAlignParagraphJustify = 3
   
    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 = True 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.ParagraphFormat.Alignment = wdAlignParagraphJustify
        objSelection.Font.Bold = True
        objSelection.Font.Color = wdColorRed
        objSelection.TypeText vbTab
        objSelection.Font.Underline = wdUnderlineSingle
        strTemp = Range("B" & i) & " " & Range("C" & i)
        objSelection.TypeText (strTemp & vbCrLf)
       
        objSelection.ClearFormatting
        objSelection.ParagraphFormat.Alignment = wdAlignParagraphJustify
        objSelection.Font.Bold = False
        objSelection.Font.Underline = wdUnderlineNone
        objSelection.Font.Color = wdColorBlack
        GorevYerleri = Join(Application.Transpose(Application.Transpose(Range("E" & i & ":" & "I" & i))), ",")
        strTemp = vbTab & 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
                objSelection.Font.Bold = True
                objSelection.TypeText vbTab & x & "- "
                objSelection.Font.Bold = False
                objSelection.TypeText MySheet.Cells(i, j) & vbCrLf
            End If
        Next
       
        objSelection.Font.Bold = True
        objSelection.TypeText vbTab & x + 1 & "- "
        objSelection.Font.Bold = False
        objSelection.TypeText "Yazı İşleri Müdürü'nün vereceği diğer işleri yapmakla görevlidir." & vbCrLf
    Next
   
    objDoc.Save
    objDoc.Close
    objWord.Quit
   
    MsgBox "Veriler aktarıldı...!" & vbCrLf & vbCrLf & "Haluk - 24/09/2019" & vbCrLf & "sa4truss@gmail.com"""
   
    Set objDoc = Nothing
    Set objWord = Nothing
End Sub

.

halit3 · 24 Eylül 2019

bu dosyalar ofis 2007 de hazırlandı birde bunu denermisiniz.

YUSUF44 · 24 Eylül 2019

halit3' Alıntı:
bu dosyalar ofis 2007 de hazırlandı birde bunu denermisiniz.

Aynı hatayı veriyor maalesef.

YUSUF44 · 24 Eylül 2019

Haluk' Alıntı:

@YUSUF44 , bahsettiğiniz konular için aşağıdaki Test4 isimli makroyu deneyebilirsiniz.

Kod:

Sub Test4()
    'Haluk - 24/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
    Const wdAlignParagraphJustify = 3
  
    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 = True 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.ParagraphFormat.Alignment = wdAlignParagraphJustify
        objSelection.Font.Bold = True
        objSelection.Font.Color = wdColorRed
        objSelection.TypeText vbTab
        objSelection.Font.Underline = wdUnderlineSingle
        strTemp = Range("B" & i) & " " & Range("C" & i)
        objSelection.TypeText (strTemp & vbCrLf)
      
        objSelection.ClearFormatting
        objSelection.ParagraphFormat.Alignment = wdAlignParagraphJustify
        objSelection.Font.Bold = False
        objSelection.Font.Underline = wdUnderlineNone
        objSelection.Font.Color = wdColorBlack
        GorevYerleri = Join(Application.Transpose(Application.Transpose(Range("E" & i & ":" & "I" & i))), ",")
        strTemp = vbTab & 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
                objSelection.Font.Bold = True
                objSelection.TypeText vbTab & x & "- "
                objSelection.Font.Bold = False
                objSelection.TypeText MySheet.Cells(i, j) & vbCrLf
            End If
        Next
      
        objSelection.Font.Bold = True
        objSelection.TypeText vbTab & x + 1 & "- "
        objSelection.Font.Bold = False
        objSelection.TypeText "Yazı İşleri Müdürü'nün vereceği diğer işleri yapmakla görevlidir." & vbCrLf
    Next
  
    objDoc.Save
    objDoc.Close
    objWord.Quit
  
    MsgBox "Veriler aktarıldı...!" & vbCrLf & vbCrLf & "Haluk - 24/09/2019" & vbCrLf & "sa4truss@gmail.com"""
  
    Set objDoc = Nothing
    Set objWord = Nothing
End Sub

.

Teşekkürler Haluk Bey. Mantığını anladım. Önce biçim seçip sonra metin eklemek gerekiyor demek ki.

Ancak paragraf hizalamayı yapmadı nedense.

Bu kodlara oluşturulan dosyayı açmak ya da bulunduğu klasörü açmak için kod eklenebilir mi?

halit3 · 24 Eylül 2019

Referansların ekran görüntüsünü ve güvenlik sekmesininde visual basic project erişimine güven seçeneğinin görüntülerini
Benim eklediğim gibi eklermisiniz.

Haluk · 24 Eylül 2019

YUSUF44' Alıntı:
.....
....

Bu kodlara oluşturulan dosyayı açmak ya da bulunduğu klasörü açmak için kod eklenebilir mi?

Buna göre revize edilmiş olan kod aşağıda verilmiştir...

Kod:

Sub Test5()
    'Haluk - 24/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
    Dim strMsg As String, myMsg As Variant
    
    Const wdGoToLine = 3
    Const wdGoToNext = 2
    Const wdColorRed = 255
    Const wdColorBlack = 0
    Const wdUnderlineSingle = 1
    Const wdUnderlineNone = 0
    Const wdAlignParagraphJustify = 3
    
    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 = True 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.ParagraphFormat.Alignment = wdAlignParagraphJustify
        objSelection.Font.Bold = True
        objSelection.Font.Color = wdColorRed
        objSelection.TypeText vbTab
        objSelection.Font.Underline = wdUnderlineSingle
        strTemp = Range("B" & i) & " " & Range("C" & i)
        objSelection.TypeText (strTemp & vbCrLf)
        
        objSelection.ClearFormatting
        objSelection.ParagraphFormat.Alignment = wdAlignParagraphJustify
        objSelection.Font.Bold = False
        objSelection.Font.Underline = wdUnderlineNone
        objSelection.Font.Color = wdColorBlack
        GorevYerleri = Join(Application.Transpose(Application.Transpose(Range("E" & i & ":" & "I" & i))), ",")
        strTemp = vbTab & 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
                objSelection.Font.Bold = True
                objSelection.TypeText vbTab & x & "- "
                objSelection.Font.Bold = False
                objSelection.TypeText MySheet.Cells(i, j) & vbCrLf
            End If
        Next
        
        objSelection.Font.Bold = True
        objSelection.TypeText vbTab & x + 1 & "- "
        objSelection.Font.Bold = False
        objSelection.TypeText "Yazı İşleri Müdürü'nün vereceği diğer işleri yapmakla görevlidir." & vbCrLf
    Next
    
    objDoc.Save
    objDoc.Close
    objWord.Quit
    
    strMsg = "Veriler WORD dosyasına aktarıldı...!" & vbCrLf & " Dosyayı açmak istiyor musunuz?"
    
    myMsg = MsgBox(strMsg & vbCrLf & vbCrLf & "Haluk - 24/09/2019" & vbCrLf & "sa4truss@gmail.com""", vbCritical + vbYesNo)

    If myMsg = vbNo Then
        Exit Sub
    ElseIf myMsg = vbYes Then
        Shell "explorer.exe" & " " & MyFile, vbNormalFocus
    End If

    Set objDoc = Nothing
    Set objWord = Nothing
End Sub

.

halit3 · 24 Eylül 2019

Bu dosyada referansları kaldırdım.

YUSUF44 · 24 Eylül 2019

halit3' Alıntı:
Referansların ekran görüntüsünü ve güvenlik sekmesininde visual basic project erişimine güven seçeneğinin görüntülerini
Benim eklediğim gibi eklermisiniz.

Ekledim Halit Bey. Çok zahmet verdim size, kusura bakmayın.

YUSUF44 · 24 Eylül 2019

halit3' Alıntı:
Bu dosyada referansları kaldırdım.

Bunda da aynı hatayı veriyor maalesef. Muhtemelen benim bilgisayarımla ilgili bir sorun.

Haluk Bey'in çözümü tam istediğim sonucu veriyor şu anda. Size de çok zahmet verdim. Teşekkür ederim ilginiz için.

YUSUF44 · 24 Eylül 2019

Haluk' Alıntı:
Buna göre revize edilmiş olan kod aşağıda verilmiştir...

.

Çok teşekkür ederim Haluk Bey. Tam istediğim gibi oldu şu anda. Allah razı olsun.

Excel'den word'e veri aktarma

Uzman

Destek Ekibi

Destek Ekibi

Destek Ekibi

Destek Ekibi

Uzman

Destek Ekibi

Uzman

Destek Ekibi

Ekli dosyalar

Destek Ekibi

Özel Üye

Uzman

Destek Ekibi

Destek Ekibi

Uzman

Özel Üye

Uzman

Destek Ekibi

Destek Ekibi

Destek Ekibi