Soru VBA Word Doldurma Hatası Hakkında

[RBozkurt]

Merhaba,

Ekteki dosyada 2 adet makro var.
2 adet tutanak doldurma işlemi için ayarladım.

Word hata verdiği için içinde birde word kapatma makrosu koydum.

Butona tıklayınca çalıştırınca belgeleri oluşturmuyor. Yardımcı olabilirmisiniz?
Oluşturursa da diğer makrodakini oluşturmuyor. PC sapıtıyor.

*

Yukarıdakilerin haricinde oluşturduğum projede ne zaman girsem seçeneklerden formül yenileme pasif gözüküyor. El ile aktif yapıyorum.
Muhtemelen makroların birinde kod pasife çekiyor.

Hangi kod olabilir? Nasıl bulabilirim veya hangi kelime geçen kodla bakmam gerekir.

Teşekkür ederim.

 

[halit3]

Kodu kendi dosyanızda böyle denermisiniz.

Sub ZZZZ_Uzlaşma_Hazırla()
Dim Uzlasma As Word.Document

Set R1 = ThisWorkbook.Worksheets("Kaynak1")
Set R2 = ThisWorkbook.Worksheets("ProjeBilgileri")
sonsatir = R1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
yoll = ThisWorkbook.Path & "\Tutanak\Uzlaşma Tutanakları\"

Sablon = ThisWorkbook.Path & "\Şablon\UZLAŞMA.docx"

kaydet2 = ThisWorkbook.Path & "\Tutanak\"
kaydet1 = ThisWorkbook.Path & "\Tutanak\Uzlaşma Tutanakları\"

If Len(Dir(kaydet2, vbDirectory)) = 0 Then MkDir kaydet2
If Len(Dir(kaydet1, vbDirectory)) = 0 Then MkDir kaydet1

For i = 2 To sonsatir
Set msword = CreateObject("word.application")
msword.Visible = True
Set Uzlasma = msword.Documents.Open(Filename:=Sablon, ReadOnly:=False)

Uzlasma.Bookmarks("Ada").Range = R1.Cells(i, "F")
Uzlasma.Bookmarks("Parsel").Range = R1.Cells(i, "G")
Uzlasma.Bookmarks("AdıSoyadı").Range = R1.Cells(i, "H")
Uzlasma.Bookmarks("AdıSoyadı2").Range = R1.Cells(i, "H")
Uzlasma.Bookmarks("BabaAdı").Range = R1.Cells(i, "I")
Uzlasma.Bookmarks("Cins").Range = R1.Cells(i, "K")
Uzlasma.Bookmarks("DoğumTarihi").Range = R1.Cells(i, "T")
Uzlasma.Bookmarks("Hissesi").Range = R1.Cells(i, "J")
Uzlasma.Bookmarks("İl").Range = R1.Cells(i, "C")
Uzlasma.Bookmarks("İlçe").Range = R1.Cells(i, "D")
Uzlasma.Bookmarks("İrtifak").Range = R1.Cells(i, "N")
Uzlasma.Bookmarks("İrtifak2").Range = R1.Cells(i, "N")
Uzlasma.Bookmarks("İrtifakBedel").Range = R1.Cells(i, "Q")
Uzlasma.Bookmarks("İstimlak").Range = R1.Cells(i, "M")
Uzlasma.Bookmarks("İstimlak2").Range = R1.Cells(i, "M")
Uzlasma.Bookmarks("İstimlakBedel").Range = R1.Cells(i, "P")
Uzlasma.Bookmarks("KDN").Range = R1.Cells(i, "B")
Uzlasma.Bookmarks("Mahalle").Range = R1.Cells(i, "E")
Uzlasma.Bookmarks("TC").Range = R1.Cells(i, "S")
Uzlasma.Bookmarks("ToplamBedel").Range = R1.Cells(i, "R")
Uzlasma.Bookmarks("YüzÖlçüm").Range = R1.Cells(i, "L")

'Alttaki satırda çağrılacak veriler tüm sayfalar için sabittir.
Uzlasma.Bookmarks("TesisBilgisi").Range = R2.Cells(1, 2) 'TÜM DOSYALARA R2 SAYFASI B1 HÜCRESİ ÇEKİLECEK'
Uzlasma.Bookmarks("YKKTarih").Range = R2.Cells(2, 2) 'TÜM DOSYALARA R2 SAYFASI B2 HÜCRESİ ÇEKİLECEK'
Uzlasma.Bookmarks("YKKSayı").Range = R2.Cells(3, 2) 'TÜM DOSYALARA R2 SAYFASI B3 HÜCRESİ ÇEKİLECEK'

Uzlasma.SaveAs yoll & R1.Cells(i, "B") & " - " & R1.Cells(i, "H") & " (TC " & R1.Cells(i, "S") & ")" & ".docx"


Uzlasma.Close
msword.Quit SaveChanges:=wdSaveChanges
Next i


MsgBox "işlem tamam"
End Sub

 

[Asri]

Alternetif;

@halit3 ün kodlarında, sonsatir tespiti ve kaydederken dosya adı düzenlemesi eklendi.

Ekli dosyada, word kapat işlemi dahil edildi.

Bu işleme benzer bir işlemi kendi programımda bul değiştir ile yapıyorum.
Aternatif olarak araştırabilirsiniz.
{adisoyadi} word de bu tarz degisken kelimeler tanımlayıp excel ile bunları bul değiştir yapabilirsiniz.
Belki de daha zor bilemiyorum. Alternatif olarak düşünülebilir.

Sub ZZZZ_Uzlaşma_Hazırla()
Dim Uzlasma As Word.Document

Set R1 = ThisWorkbook.Worksheets("Kaynak1")
Set R2 = ThisWorkbook.Worksheets("ProjeBilgileri")

'sonsatir = R1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sonsatir = Cells(Rows.Count, "C").End(3).Row
yoll = ThisWorkbook.Path & "\Tutanak\Uzlaşma Tutanakları\"

Sablon = ThisWorkbook.Path & "\Şablon\UZLAŞMA.docx"

kaydet2 = ThisWorkbook.Path & "\Tutanak\"
kaydet1 = ThisWorkbook.Path & "\Tutanak\Uzlaşma Tutanakları\"

If Len(Dir(kaydet2, vbDirectory)) = 0 Then MkDir kaydet2
If Len(Dir(kaydet1, vbDirectory)) = 0 Then MkDir kaydet1

For i = 2 To sonsatir
Set msword = CreateObject("word.application")
msword.Visible = True
Set Uzlasma = msword.Documents.Open(Filename:=Sablon, ReadOnly:=False)

Uzlasma.Bookmarks("Ada").Range = R1.Cells(i, "F")
Uzlasma.Bookmarks("Parsel").Range = R1.Cells(i, "G")
Uzlasma.Bookmarks("AdıSoyadı").Range = R1.Cells(i, "H")
Uzlasma.Bookmarks("AdıSoyadı2").Range = R1.Cells(i, "H")
Uzlasma.Bookmarks("BabaAdı").Range = R1.Cells(i, "I")
Uzlasma.Bookmarks("Cins").Range = R1.Cells(i, "K")
Uzlasma.Bookmarks("DoğumTarihi").Range = R1.Cells(i, "T")
Uzlasma.Bookmarks("Hissesi").Range = R1.Cells(i, "J")
Uzlasma.Bookmarks("İl").Range = R1.Cells(i, "C")
Uzlasma.Bookmarks("İlçe").Range = R1.Cells(i, "D")
Uzlasma.Bookmarks("İrtifak").Range = R1.Cells(i, "N")
Uzlasma.Bookmarks("İrtifak2").Range = R1.Cells(i, "N")
Uzlasma.Bookmarks("İrtifakBedel").Range = R1.Cells(i, "Q")
Uzlasma.Bookmarks("İstimlak").Range = R1.Cells(i, "M")
Uzlasma.Bookmarks("İstimlak2").Range = R1.Cells(i, "M")
Uzlasma.Bookmarks("İstimlakBedel").Range = R1.Cells(i, "P")
Uzlasma.Bookmarks("KDN").Range = R1.Cells(i, "B")
Uzlasma.Bookmarks("Mahalle").Range = R1.Cells(i, "E")
Uzlasma.Bookmarks("TC").Range = R1.Cells(i, "S")
Uzlasma.Bookmarks("ToplamBedel").Range = R1.Cells(i, "R")
Uzlasma.Bookmarks("YüzÖlçüm").Range = R1.Cells(i, "L")

'Alttaki satırda çağrılacak veriler tüm sayfalar için sabittir.
Uzlasma.Bookmarks("TesisBilgisi").Range = R2.Cells(1, 2) 'TÜM DOSYALARA R2 SAYFASI B1 HÜCRESİ ÇEKİLECEK'
Uzlasma.Bookmarks("YKKTarih").Range = R2.Cells(2, 2) 'TÜM DOSYALARA R2 SAYFASI B2 HÜCRESİ ÇEKİLECEK'
Uzlasma.Bookmarks("YKKSayı").Range = R2.Cells(3, 2) 'TÜM DOSYALARA R2 SAYFASI B3 HÜCRESİ ÇEKİLECEK'

dosyaadi = R1.Cells(i, "B") & " - " & R1.Cells(i, "H") & " (TC " & R1.Cells(i, "S") & ")"
MyArray = Array("<", ">", "|", "/", "*", "\", ".", "?", """")
For X = LBound(MyArray) To UBound(MyArray)
    dosyaadi = Replace(dosyaadi, MyArray(X), "_", 1)
Next X
dosyayol = yoll & dosyaadi & ".docx"
Uzlasma.SaveAs dosyayol


Uzlasma.Close
msword.Quit SaveChanges:=wdSaveChanges
Next i

End Sub

Not : Dosya @RBozkurt un talebi üzerine silindi... (kişisel veri içeriği)

 

[RBozkurt]

Sayın @halit3 ve @Asri ikinize de çok teşekkürler. Elinize sağlık

Ayrıca bu işlem için ayrıca teşekkür ederim. Aklıma gelmemişti bu şekilde isimlendirmede hata verebilecek kelimeler denk gelecektir.
MyArray = Array("<", ">", "|", "/", "*", "\", ".", "?", """")

Sayın @Asri
Bu şekilde {adisoyadi} bul değiştir işlemine bakmaya çalıştım fakat youtubede denk gelemedim.
Müsait olduğunuzda 1 2 kelimelik örnek dosya veye varsa link vb. atabilirmisiniz?

 

[Asri]

Sayın @Asri
Bu şekilde {adisoyadi} bul değiştir işlemine bakmaya çalıştım fakat youtubede denk gelemedim.
Müsait olduğunuzda 1 2 kelimelik örnek dosya veye varsa link vb. atabilirmisiniz?

Word şablon dosyanızda {adisoyadi} bilgisini girin.
Aşağıdaki kodu çalıştırıp sonuca bakın.

Sub ZZZZ_Uzlaşma_Hazırla()
Dim Uzlasma As Word.Document

Set R1 = ThisWorkbook.Worksheets("Kaynak1")
Set R2 = ThisWorkbook.Worksheets("ProjeBilgileri")

'sonsatir = R1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sonsatir = Cells(Rows.Count, "C").End(3).Row
yoll = ThisWorkbook.Path & "\Tutanak\Uzlaşma Tutanakları\"

Sablon = ThisWorkbook.Path & "\Şablon\UZLAŞMA.docx"

kaydet2 = ThisWorkbook.Path & "\Tutanak\"
kaydet1 = ThisWorkbook.Path & "\Tutanak\Uzlaşma Tutanakları\"

If Len(Dir(kaydet2, vbDirectory)) = 0 Then MkDir kaydet2
If Len(Dir(kaydet1, vbDirectory)) = 0 Then MkDir kaydet1

For i = 2 To sonsatir
Set msword = CreateObject("word.application")
msword.Visible = True
Set Uzlasma = msword.Documents.Open(Filename:=Sablon, ReadOnly:=False)
  
   'Değişken ile bilgi değiştirme başla
    With msword.ActiveDocument
         Set myRange = .Content
         With myRange.Find
             .Execute FindText:="{adisoyadi}", ReplaceWith:=R1.Cells(i, "H"), Replace:=2
         End With
   End With
     'Değişken ile bilgi değiştirme bitir

Uzlasma.Bookmarks("Ada").Range = R1.Cells(i, "F")
Uzlasma.Bookmarks("Parsel").Range = R1.Cells(i, "G")
Uzlasma.Bookmarks("AdıSoyadı").Range = R1.Cells(i, "H")
Uzlasma.Bookmarks("AdıSoyadı2").Range = R1.Cells(i, "H")
Uzlasma.Bookmarks("BabaAdı").Range = R1.Cells(i, "I")
Uzlasma.Bookmarks("Cins").Range = R1.Cells(i, "K")
Uzlasma.Bookmarks("DoğumTarihi").Range = R1.Cells(i, "T")
Uzlasma.Bookmarks("Hissesi").Range = R1.Cells(i, "J")
Uzlasma.Bookmarks("İl").Range = R1.Cells(i, "C")
Uzlasma.Bookmarks("İlçe").Range = R1.Cells(i, "D")
Uzlasma.Bookmarks("İrtifak").Range = R1.Cells(i, "N")
Uzlasma.Bookmarks("İrtifak2").Range = R1.Cells(i, "N")
Uzlasma.Bookmarks("İrtifakBedel").Range = R1.Cells(i, "Q")
Uzlasma.Bookmarks("İstimlak").Range = R1.Cells(i, "M")
Uzlasma.Bookmarks("İstimlak2").Range = R1.Cells(i, "M")
Uzlasma.Bookmarks("İstimlakBedel").Range = R1.Cells(i, "P")
Uzlasma.Bookmarks("KDN").Range = R1.Cells(i, "B")
Uzlasma.Bookmarks("Mahalle").Range = R1.Cells(i, "E")
Uzlasma.Bookmarks("TC").Range = R1.Cells(i, "S")
Uzlasma.Bookmarks("ToplamBedel").Range = R1.Cells(i, "R")
Uzlasma.Bookmarks("YüzÖlçüm").Range = R1.Cells(i, "L")

'Alttaki satırda çağrılacak veriler tüm sayfalar için sabittir.
Uzlasma.Bookmarks("TesisBilgisi").Range = R2.Cells(1, 2) 'TÜM DOSYALARA R2 SAYFASI B1 HÜCRESİ ÇEKİLECEK'
Uzlasma.Bookmarks("YKKTarih").Range = R2.Cells(2, 2) 'TÜM DOSYALARA R2 SAYFASI B2 HÜCRESİ ÇEKİLECEK'
Uzlasma.Bookmarks("YKKSayı").Range = R2.Cells(3, 2) 'TÜM DOSYALARA R2 SAYFASI B3 HÜCRESİ ÇEKİLECEK'

dosyaadi = R1.Cells(i, "B") & " - " & R1.Cells(i, "H") & " (TC " & R1.Cells(i, "S") & ")"
MyArray = Array("<", ">", "|", "/", "*", "\", ".", "?", """")
For X = LBound(MyArray) To UBound(MyArray)
    dosyaadi = Replace(dosyaadi, MyArray(X), "_", 1)
Next X
dosyayol = yoll & dosyaadi & ".docx"
Uzlasma.SaveAs dosyayol


Uzlasma.Close
msword.Quit SaveChanges:=wdSaveChanges
Next i

End Sub

 

[RBozkurt]

Yukarıdakilerin haricinde oluşturduğum projede ne zaman girsem seçeneklerden formül yenileme pasif gözüküyor. El ile aktif yapıyorum.
Muhtemelen makroların birinde kod pasife çekiyor.

Hangi kod olabilir? Nasıl bulabilirim veya hangi kelime geçen kodla bakmam gerekir.

Yukarıdaki hatanın sebebini buldum.
Makronun birinde alttaki pasif olarak yazdığım kod var, sonda aktif kodu eksik kalmış. Ekledim düzeldi.

Pasif

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .Calculation = xlManual
    End With

Aktif

    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
        .Calculation = xlAutomatic
    End With

@Asri teşekkür ederim deneyip geri dönüş bırakırım.

Word şablon dosyanızda {adisoyadi} bilgisini girin.
Aşağıdaki kodu çalıştırıp sonuca bakın.

Sub ZZZZ_Uzlaşma_Hazırla()
Dim Uzlasma As Word.Document

Set R1 = ThisWorkbook.Worksheets("Kaynak1")
Set R2 = ThisWorkbook.Worksheets("ProjeBilgileri")

'sonsatir = R1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sonsatir = Cells(Rows.Count, "C").End(3).Row
yoll = ThisWorkbook.Path & "\Tutanak\Uzlaşma Tutanakları\"

Sablon = ThisWorkbook.Path & "\Şablon\UZLAŞMA.docx"

kaydet2 = ThisWorkbook.Path & "\Tutanak\"
kaydet1 = ThisWorkbook.Path & "\Tutanak\Uzlaşma Tutanakları\"

If Len(Dir(kaydet2, vbDirectory)) = 0 Then MkDir kaydet2
If Len(Dir(kaydet1, vbDirectory)) = 0 Then MkDir kaydet1

For i = 2 To sonsatir
Set msword = CreateObject("word.application")
msword.Visible = True
Set Uzlasma = msword.Documents.Open(Filename:=Sablon, ReadOnly:=False)
 
   'Değişken ile bilgi değiştirme başla
    With msword.ActiveDocument
         Set myRange = .Content
         With myRange.Find
             .Execute FindText:="{adisoyadi}", ReplaceWith:=R1.Cells(i, "H"), Replace:=2
         End With
   End With
     'Değişken ile bilgi değiştirme bitir

Uzlasma.Bookmarks("Ada").Range = R1.Cells(i, "F")
Uzlasma.Bookmarks("Parsel").Range = R1.Cells(i, "G")
Uzlasma.Bookmarks("AdıSoyadı").Range = R1.Cells(i, "H")
Uzlasma.Bookmarks("AdıSoyadı2").Range = R1.Cells(i, "H")
Uzlasma.Bookmarks("BabaAdı").Range = R1.Cells(i, "I")
Uzlasma.Bookmarks("Cins").Range = R1.Cells(i, "K")
Uzlasma.Bookmarks("DoğumTarihi").Range = R1.Cells(i, "T")
Uzlasma.Bookmarks("Hissesi").Range = R1.Cells(i, "J")
Uzlasma.Bookmarks("İl").Range = R1.Cells(i, "C")
Uzlasma.Bookmarks("İlçe").Range = R1.Cells(i, "D")
Uzlasma.Bookmarks("İrtifak").Range = R1.Cells(i, "N")
Uzlasma.Bookmarks("İrtifak2").Range = R1.Cells(i, "N")
Uzlasma.Bookmarks("İrtifakBedel").Range = R1.Cells(i, "Q")
Uzlasma.Bookmarks("İstimlak").Range = R1.Cells(i, "M")
Uzlasma.Bookmarks("İstimlak2").Range = R1.Cells(i, "M")
Uzlasma.Bookmarks("İstimlakBedel").Range = R1.Cells(i, "P")
Uzlasma.Bookmarks("KDN").Range = R1.Cells(i, "B")
Uzlasma.Bookmarks("Mahalle").Range = R1.Cells(i, "E")
Uzlasma.Bookmarks("TC").Range = R1.Cells(i, "S")
Uzlasma.Bookmarks("ToplamBedel").Range = R1.Cells(i, "R")
Uzlasma.Bookmarks("YüzÖlçüm").Range = R1.Cells(i, "L")

'Alttaki satırda çağrılacak veriler tüm sayfalar için sabittir.
Uzlasma.Bookmarks("TesisBilgisi").Range = R2.Cells(1, 2) 'TÜM DOSYALARA R2 SAYFASI B1 HÜCRESİ ÇEKİLECEK'
Uzlasma.Bookmarks("YKKTarih").Range = R2.Cells(2, 2) 'TÜM DOSYALARA R2 SAYFASI B2 HÜCRESİ ÇEKİLECEK'
Uzlasma.Bookmarks("YKKSayı").Range = R2.Cells(3, 2) 'TÜM DOSYALARA R2 SAYFASI B3 HÜCRESİ ÇEKİLECEK'

dosyaadi = R1.Cells(i, "B") & " - " & R1.Cells(i, "H") & " (TC " & R1.Cells(i, "S") & ")"
MyArray = Array("<", ">", "|", "/", "*", "\", ".", "?", """")
For X = LBound(MyArray) To UBound(MyArray)
    dosyaadi = Replace(dosyaadi, MyArray(X), "_", 1)
Next X
dosyayol = yoll & dosyaadi & ".docx"
Uzlasma.SaveAs dosyayol


Uzlasma.Close
msword.Quit SaveChanges:=wdSaveChanges
Next i

End Sub

 

[halit3]

Bu kod çok hızlı işlem yapıyor
dosyayı bir kez açıyor ve değiştirerek işlem yapıyor.
olmayan kutucuklara siz kendiniz yapabilirsiniz.
kodun mantığı şu örnek ilçe için tablodaki hücreleri büyük küçük tek üstten soldan sayınız 13 hücre denk geliyor

Sub ZZZZ_Uzlaşma_Hazırla()
Dim Uzlasma As Word.Document

Set R1 = ThisWorkbook.Worksheets("Kaynak1")
Set R2 = ThisWorkbook.Worksheets("ProjeBilgileri")
sonsatir = R1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
yoll = ThisWorkbook.Path & "\Tutanak\Uzlaşma Tutanakları\"

Sablon = ThisWorkbook.Path & "\Şablon\UZLAŞMA.docx"

kaydet2 = ThisWorkbook.Path & "\Tutanak\"
kaydet1 = ThisWorkbook.Path & "\Tutanak\Uzlaşma Tutanakları\"

If Len(Dir(kaydet2, vbDirectory)) = 0 Then MkDir kaydet2
If Len(Dir(kaydet1, vbDirectory)) = 0 Then MkDir kaydet1

Set msword = CreateObject("word.application")
msword.Visible = True
Set Uzlasma = msword.Documents.Open(Filename:=Sablon, ReadOnly:=False)


For i = 2 To sonsatir


Uzlasma.Tables.Item(1).Range.Cells(5).Range = R1.Cells(i, "B")
Uzlasma.Tables.Item(1).Range.Cells(7).Range = R1.Cells(i, "C")
Uzlasma.Tables.Item(1).Range.Cells(9).Range = R1.Cells(i, "F") & "/" & R1.Cells(i, "G")
Uzlasma.Tables.Item(1).Range.Cells(11).Range = R1.Cells(i, "L")
Uzlasma.Tables.Item(1).Range.Cells(13).Range = R1.Cells(i, "d")
Uzlasma.Tables.Item(1).Range.Cells(15).Range = R1.Cells(i, "K")

Uzlasma.Tables.Item(1).Range.Cells(19).Range = R1.Cells(i, "E")
Uzlasma.Tables.Item(1).Range.Cells(26).Range = R1.Cells(i, "S")
Uzlasma.Tables.Item(1).Range.Cells(30).Range = R1.Cells(i, "H")
Uzlasma.Tables.Item(1).Range.Cells(34).Range = R1.Cells(i, "I")
Uzlasma.Tables.Item(1).Range.Cells(36).Range = R1.Cells(i, "J")

Uzlasma.Tables.Item(1).Range.Cells(46).Range = R2.Cells(5, 2) & Chr(10) & R2.Cells(6, 2)
Uzlasma.Tables.Item(1).Range.Cells(47).Range = R2.Cells(7, 2) & Chr(10) & R2.Cells(8, 2)
Uzlasma.Tables.Item(1).Range.Cells(48).Range = R2.Cells(9, 2) & Chr(10) & R2.Cells(10, 2)

Uzlasma.SaveAs yoll & R1.Cells(i, "B") & " - " & R1.Cells(i, "H") & " (TC " & R1.Cells(i, "S") & ")" & ".docx"

Next i
Uzlasma.Close
msword.Quit SaveChanges:=wdSaveChanges

MsgBox "işlem tamam"
End Sub

 

[RBozkurt]

Yarın gün içinde dönüş yapacağım sayın @halit3 emeğinize sağlık. Teşekkür ederim.

 

[RBozkurt]

Bu kod çok hızlı işlem yapıyor
dosyayı bir kez açıyor ve değiştirerek işlem yapıyor.
olmayan kutucuklara siz kendiniz yapabilirsiniz.
kodun mantığı şu örnek ilçe için tablodaki hücreleri büyük küçük tek üstten soldan sayınız 13 hücre denk geliyor

Sub ZZZZ_Uzlaşma_Hazırla()
Dim Uzlasma As Word.Document

Set R1 = ThisWorkbook.Worksheets("Kaynak1")
Set R2 = ThisWorkbook.Worksheets("ProjeBilgileri")
sonsatir = R1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
yoll = ThisWorkbook.Path & "\Tutanak\Uzlaşma Tutanakları\"

Sablon = ThisWorkbook.Path & "\Şablon\UZLAŞMA.docx"

kaydet2 = ThisWorkbook.Path & "\Tutanak\"
kaydet1 = ThisWorkbook.Path & "\Tutanak\Uzlaşma Tutanakları\"

If Len(Dir(kaydet2, vbDirectory)) = 0 Then MkDir kaydet2
If Len(Dir(kaydet1, vbDirectory)) = 0 Then MkDir kaydet1

Set msword = CreateObject("word.application")
msword.Visible = True
Set Uzlasma = msword.Documents.Open(Filename:=Sablon, ReadOnly:=False)


For i = 2 To sonsatir


Uzlasma.Tables.Item(1).Range.Cells(5).Range = R1.Cells(i, "B")
Uzlasma.Tables.Item(1).Range.Cells(7).Range = R1.Cells(i, "C")
Uzlasma.Tables.Item(1).Range.Cells(9).Range = R1.Cells(i, "F") & "/" & R1.Cells(i, "G")
Uzlasma.Tables.Item(1).Range.Cells(11).Range = R1.Cells(i, "L")
Uzlasma.Tables.Item(1).Range.Cells(13).Range = R1.Cells(i, "d")
Uzlasma.Tables.Item(1).Range.Cells(15).Range = R1.Cells(i, "K")

Uzlasma.Tables.Item(1).Range.Cells(19).Range = R1.Cells(i, "E")
Uzlasma.Tables.Item(1).Range.Cells(26).Range = R1.Cells(i, "S")
Uzlasma.Tables.Item(1).Range.Cells(30).Range = R1.Cells(i, "H")
Uzlasma.Tables.Item(1).Range.Cells(34).Range = R1.Cells(i, "I")
Uzlasma.Tables.Item(1).Range.Cells(36).Range = R1.Cells(i, "J")

Uzlasma.Tables.Item(1).Range.Cells(46).Range = R2.Cells(5, 2) & Chr(10) & R2.Cells(6, 2)
Uzlasma.Tables.Item(1).Range.Cells(47).Range = R2.Cells(7, 2) & Chr(10) & R2.Cells(8, 2)
Uzlasma.Tables.Item(1).Range.Cells(48).Range = R2.Cells(9, 2) & Chr(10) & R2.Cells(10, 2)

Uzlasma.SaveAs yoll & R1.Cells(i, "B") & " - " & R1.Cells(i, "H") & " (TC " & R1.Cells(i, "S") & ")" & ".docx"

Next i
Uzlasma.Close
msword.Quit SaveChanges:=wdSaveChanges

MsgBox "işlem tamam"
End Sub

Makroyu denedim gerçekten çok hızlı.
Diğeri her defa aç kapa aç kapa şeklinde yapıyor.
Bunda hemen sonuçlanıyor.

Öncelikle metin içine veri çağırırken nasıl bir yol izlemeliyim?
...... ala ... tl gibi.

O kısımlara hücre oluşturup mu atlamalıyım? Teşekkürler.

 

[halit3]

Tam olarak ne demek istediniz anlamadım.

 

[RBozkurt]

Tam olarak ne demek istediniz anlamadım.

Resimdeki gibi 1 tane hücre içinde kırmızı kutuların olduğu yerlere gelecek veriler var. Bunları diğer hücreler gibi ayrı ayrı hücre olarak mı tanımlamak gerekir?

 

[halit3]

Resimden pek anlaşılmıyor.
Ama bu tablomu yoksa nesnemi bilmiyorum tablo ise tablo adını tanımlamak nesne ise nesne adını tanımlamak gerekeceği kanaatindeyim.

 

[RBozkurt]

Resimden pek anlaşılmıyor.
Ama bu tablomu yoksa nesnemi bilmiyorum tablo ise tablo adını tanımlamak nesne ise nesne adını tanımlamak gerekeceği kanaatindeyim.

Yukarıda 1. mesajdaki ekte bulunan şablon dosyasındaki satırlar, resim olarak ekledim.

 

[RBozkurt]

Sayın @halit3
Her ikisi içinde şablonları düzenledim;
- 2. mesajdaki kodlar 12 satırlık veriyi 28 saniyede
- 7. mesajdaki kodlar 12 satırlık veriyi 13 saniyede oluşturuyor.

Elinize sağlık her ikisi içinde teşekkürler.

Sayın @Asri
Alttaki kodlar içinde tekrar teşekkürler. Çok işime yaradı.

dosyaadi = R1.Cells(i, "B") & " - " & R1.Cells(i, "H") & " (TC " & R1.Cells(i, "S") & ")"
MyArray = Array("<", ">", "|", "/", "*", "\", ".", "?", """")
For X = LBound(MyArray) To UBound(MyArray)
    dosyaadi = Replace(dosyaadi, MyArray(X), "_", 1)
Next X
dosyayol = yoll & dosyaadi & ".docx"
Uzlasma.SaveAs dosyayol

 

[halit3]

Okumak için böyle yapmak lazım

MsgBox Uzlasma.Tables.Item(1).Range.Cells(41).Range

değiştirmek içinde baya uğraşmak gerekiyor

yer = "Türkiye Elektrik Dağıtım A.Ş. Yönetim Kurulundan alınantarih,no’lu kamu yararı/kamulaştırma kararına istinaden kamulaştırma işlemlerine başlanan yukarıda tapu kaydı ile özellikleri yazılı taşınmaza ilişkin TEDAŞ Kıymet Takdir Komisyonunca belirlenen tahmini bedeller doğrultusunda taşınmaz maliki/kanuni vekili ile yapılan pazarlık sonucunda taşınmaz malikinin hissesi oranındaki;" _
& "m² mülkiyet içinTL," _
& "m² irtifak hakkı içinTL," _
& "0.00 TL"

Uzlasma.Tables.Item(1).Range.Cells(41).Range = yer

 

[RBozkurt]

@halit3 yeni kodlar için teşekkürler.
15. mesajdaki kodlar içerisindeki "yer =" ibaresinin olduğu veriyi ***** olarak veya örnek1 gibi bişeyde güncelleyebilirmisiniz? Bana problem çıkartabilir

 

[halit3]

Bunu bir dene

With Uzlasma.Tables.Item(1).Range.Cells(41).Range.Find 
.ClearFormatting
.Text = "TL"
.Replacement.ClearFormatting
.Replacement.Text = "krş"
.Execute Replace:=wdReplaceAll, Forward:=True, _
Wrap:=wdFindContinue
End With

 

[RBozkurt]

En son çalışan hali alttaki.
Şablonu uyacak şekilde tekrardan düzenledim.

Ek olarak 15. mesajdaki kısmı word şablondaki hücreleri yeniden düzenledikten sonra deneyebilirim. Ordaki metinleri verdiğiniz şekilde tanımlayıp işleme devam ettirebilirim. Alan ve bedellerin geldiği yere hücre eklemiştim onları iptal edip kaydırmam lazım şablonu.

Sub ZZZZ_Uzlaşma_Hazırla_Hücre()
Dim Uzlasma As Word.Document

Set R1 = ThisWorkbook.Worksheets("Kaynak1")
Set R2 = ThisWorkbook.Worksheets("ProjeBilgileri")
sonsatir = R1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
yoll = ThisWorkbook.Path & "\Tutanak\Uzlaşma Tutanakları\"

Sablon = ThisWorkbook.Path & "\Şablon2\UZLAŞMA.docx"

kaydet2 = ThisWorkbook.Path & "\Tutanak\"
kaydet1 = ThisWorkbook.Path & "\Tutanak\Uzlaşma Tutanakları\"

If Len(Dir(kaydet2, vbDirectory)) = 0 Then MkDir kaydet2
If Len(Dir(kaydet1, vbDirectory)) = 0 Then MkDir kaydet1

Set msword = CreateObject("word.application")
msword.Visible = True
Set Uzlasma = msword.Documents.Open(Filename:=Sablon, ReadOnly:=False)


For i = 2 To sonsatir

Uzlasma.Tables.Item(1).Range.Cells(3).Range = R2.Cells(1, 2)    'TESİS BİLGİSİ
Uzlasma.Tables.Item(1).Range.Cells(7).Range = R1.Cells(i, "B")  'KDN
Uzlasma.Tables.Item(1).Range.Cells(9).Range = R1.Cells(i, "C")  'İL
Uzlasma.Tables.Item(1).Range.Cells(9).Range = R1.Cells(i, "F") & "/" & R1.Cells(i, "G") 'ADA/PARSEL
Uzlasma.Tables.Item(1).Range.Cells(13).Range = R1.Cells(i, "L") 'YÜZÖLÇÜM
Uzlasma.Tables.Item(1).Range.Cells(15).Range = R1.Cells(i, "D") 'İLÇE
Uzlasma.Tables.Item(1).Range.Cells(17).Range = R1.Cells(i, "K") 'NİTELİK
Uzlasma.Tables.Item(1).Range.Cells(19).Range = R1.Cells(i, "M") 'İSTİMLAK ALAN
Uzlasma.Tables.Item(1).Range.Cells(21).Range = R1.Cells(i, "E") 'MAHALLE
Uzlasma.Tables.Item(1).Range.Cells(23).Range = R1.Cells(i, "N") 'İRTİFAK ALAN
Uzlasma.Tables.Item(1).Range.Cells(26).Range = R1.Cells(i, "S") 'TC
Uzlasma.Tables.Item(1).Range.Cells(30).Range = R1.Cells(i, "H") 'ADI SOYADI
Uzlasma.Tables.Item(1).Range.Cells(32).Range = R1.Cells(i, "T") 'DOĞUM YILI
Uzlasma.Tables.Item(1).Range.Cells(34).Range = R1.Cells(i, "I") 'BABA ADI
Uzlasma.Tables.Item(1).Range.Cells(36).Range = R1.Cells(i, "J") 'HİSSE
Uzlasma.Tables.Item(1).Range.Cells(42).Range = R2.Cells(2, 2)   'YKK TARİH
Uzlasma.Tables.Item(1).Range.Cells(44).Range = R2.Cells(3, 2)   'YKK SAYI
Uzlasma.Tables.Item(1).Range.Cells(47).Range = R1.Cells(i, "M") 'İSTİMLAK ALAN
Uzlasma.Tables.Item(1).Range.Cells(49).Range = R1.Cells(i, "P") 'İSTİMLAK BEDEL
Uzlasma.Tables.Item(1).Range.Cells(51).Range = R1.Cells(i, "N") 'İRTİFAK ALAN
Uzlasma.Tables.Item(1).Range.Cells(53).Range = R1.Cells(i, "Q") 'İRTİFAK BEDEL
Uzlasma.Tables.Item(1).Range.Cells(57).Range = R1.Cells(i, "R") 'TOPLAM BEDEL
Uzlasma.Tables.Item(1).Range.Cells(64).Range = R2.Cells(5, 2) & Chr(10) & R2.Cells(6, 2)    'BAŞKAN
Uzlasma.Tables.Item(1).Range.Cells(65).Range = R2.Cells(7, 2) & Chr(10) & R2.Cells(8, 2)    'ÜYE1
Uzlasma.Tables.Item(1).Range.Cells(66).Range = R2.Cells(9, 2) & Chr(10) & R2.Cells(10, 2)   'ÜYE2
Uzlasma.Tables.Item(1).Range.Cells(67).Range = R1.Cells(i, "H") 'ADI SOYADI

'KAYIT VERİLERİ
DosyaAdi = R1.Cells(i, "B") & " - " & R1.Cells(i, "H") & R1.Cells(i, "J") & " (TC " & R1.Cells(i, "S") & ")" & " Uzlaşma"
MyArray = Array("<", ">", "|", "/", " / ", "*", "\", " \ ", ".", "?", """")
For X = LBound(MyArray) To UBound(MyArray)
    DosyaAdi = Replace(DosyaAdi, MyArray(X), "_", 1)
Next X
dosyayol = yoll & DosyaAdi & ".docx"
Uzlasma.SaveAs dosyayol

Next i
Uzlasma.Close
msword.Quit SaveChanges:=wdSaveChanges

End Sub

 

[RBozkurt]

Tablo yöntemi süre olarak çok çok daha hızlı, fakat şablonu güncelleme ihtiyacı olunca makroyu güncellemek gerekecek.

İlk yöntem yavaş ama bookmark ekleme işlemi yukarıdaki işlemlerden daha basit. Farklı kullanıcı güncelleme yapmak isterse tarif edebilirim. Başka kişilerde kullanacağı için ilk yöntemden devam edeceğim. Her iki örnekte çalışıyor. Emeklerinize teşekkür ederim.

 

[halit3]

ornek2.rar dosyasını indir - download

ornek2.rar dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s2.dosya.tc

linkdeki örnek şablon dosyasında küçük değişiklik yaptım TL bölümlerini de değiştiriyor kod