Soru VBA Word Doldurma Hatası Hakkında

RBozkurt

RBozkurt

𐱅𐰇𐰼𐰚
Altın Üye
Katılım
10 Ocak 2018
Mesajlar
745
Excel Vers. ve Dili
Microsoft Office 2024
Google Sheets
Altın Üyelik Bitiş Tarihi
19-12-2026
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

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,842
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Kodu kendi dosyanızda böyle denermisiniz.

Rich (BB code): 
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

Asri

Katılım
24 Nisan 2005
Mesajlar
3,680
Excel Vers. ve Dili
Office 2016 EN 64 Bit
Altın Üyelik Bitiş Tarihi
25/05/2022
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.


C#: 
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)
 
Moderatör tarafında düzenlendi:
RBozkurt

RBozkurt

𐱅𐰇𐰼𐰚
Altın Üye
Katılım
10 Ocak 2018
Mesajlar
745
Excel Vers. ve Dili
Microsoft Office 2024
Google Sheets
Altın Üyelik Bitiş Tarihi
19-12-2026
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

Asri

Katılım
24 Nisan 2005
Mesajlar
3,680
Excel Vers. ve Dili
Office 2016 EN 64 Bit
Altın Üyelik Bitiş Tarihi
25/05/2022
RBozkurt' Alıntı:
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?
Genişletmek için tıkla ...
Word şablon dosyanızda {adisoyadi} bilgisini girin.
Aşağıdaki kodu çalıştırıp sonuca bakın.

C#: 
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

RBozkurt

𐱅𐰇𐰼𐰚
Altın Üye
Katılım
10 Ocak 2018
Mesajlar
745
Excel Vers. ve Dili
Microsoft Office 2024
Google Sheets
Altın Üyelik Bitiş Tarihi
19-12-2026
RBozkurt' Alıntı:
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.
Genişletmek için tıkla ...
Yukarıdaki hatanın sebebini buldum.
Makronun birinde alttaki pasif olarak yazdığım kod var, sonda aktif kodu eksik kalmış. Ekledim düzeldi.

Pasif
C++: 
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .Calculation = xlManual
    End With
Aktif
C++: 
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
        .Calculation = xlAutomatic
    End With


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

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

C#: 
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
Genişletmek için tıkla ...
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,842
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
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

CSS: 
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

RBozkurt

𐱅𐰇𐰼𐰚
Altın Üye
Katılım
10 Ocak 2018
Mesajlar
745
Excel Vers. ve Dili
Microsoft Office 2024
Google Sheets
Altın Üyelik Bitiş Tarihi
19-12-2026
Yarın gün içinde dönüş yapacağım sayın @halit3 emeğinize sağlık. Teşekkür ederim.
 
RBozkurt

RBozkurt

𐱅𐰇𐰼𐰚
Altın Üye
Katılım
10 Ocak 2018
Mesajlar
745
Excel Vers. ve Dili
Microsoft Office 2024
Google Sheets
Altın Üyelik Bitiş Tarihi
19-12-2026
halit3' Alıntı:
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

CSS: 
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
Genişletmek için tıkla ...

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

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,842
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Tam olarak ne demek istediniz anlamadım.
 
RBozkurt

RBozkurt

𐱅𐰇𐰼𐰚
Altın Üye
Katılım
10 Ocak 2018
Mesajlar
745
Excel Vers. ve Dili
Microsoft Office 2024
Google Sheets
Altın Üyelik Bitiş Tarihi
19-12-2026
halit3' Alıntı:
Tam olarak ne demek istediniz anlamadım.
Genişletmek için tıkla ...
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?


234490
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,842
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
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

RBozkurt

𐱅𐰇𐰼𐰚
Altın Üye
Katılım
10 Ocak 2018
Mesajlar
745
Excel Vers. ve Dili
Microsoft Office 2024
Google Sheets
Altın Üyelik Bitiş Tarihi
19-12-2026
halit3' Alıntı:
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.
Genişletmek için tıkla ...
Yukarıda 1. mesajdaki ekte bulunan şablon dosyasındaki satırlar, resim olarak ekledim.
 
RBozkurt

RBozkurt

𐱅𐰇𐰼𐰚
Altın Üye
Katılım
10 Ocak 2018
Mesajlar
745
Excel Vers. ve Dili
Microsoft Office 2024
Google Sheets
Altın Üyelik Bitiş Tarihi
19-12-2026
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ı.

C++: 
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

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,842
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Okumak için böyle yapmak lazım

Kod: 
MsgBox Uzlasma.Tables.Item(1).Range.Cells(41).Range
değiştirmek içinde baya uğraşmak gerekiyor
Kod: 
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

RBozkurt

𐱅𐰇𐰼𐰚
Altın Üye
Katılım
10 Ocak 2018
Mesajlar
745
Excel Vers. ve Dili
Microsoft Office 2024
Google Sheets
Altın Üyelik Bitiş Tarihi
19-12-2026
@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

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,842
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Bunu bir dene
Rich (BB code): 
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

RBozkurt

𐱅𐰇𐰼𐰚
Altın Üye
Katılım
10 Ocak 2018
Mesajlar
745
Excel Vers. ve Dili
Microsoft Office 2024
Google Sheets
Altın Üyelik Bitiş Tarihi
19-12-2026
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.

C++: 
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

RBozkurt

𐱅𐰇𐰼𐰚
Altın Üye
Katılım
10 Ocak 2018
Mesajlar
745
Excel Vers. ve Dili
Microsoft Office 2024
Google Sheets
Altın Üyelik Bitiş Tarihi
19-12-2026
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

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,842
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe

ornek2.rar dosyasını indir - download

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

linkdeki örnek şablon dosyasında küçük değişiklik yaptım TL bölümlerini de değiştiriyor kod
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst