- Katılım
- 15 Mart 2005
- Mesajlar
- 42,576
- Excel Vers. ve Dili
- Microsoft 365 Tr-En 64 Bit
Paylaşmış olduğum kodu revize ettim. Tekrar deneyiniz.
-
DİKKAT DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Soru VBA Word Doldurma Hatası Hakkında
- Konbuyu başlatan RBozkurt
- Başlangıç tarihi
- Katılım
- 15 Mart 2005
- Mesajlar
- 42,576
- Excel Vers. ve Dili
- Microsoft 365 Tr-En 64 Bit
Benim paylaşımımda zaten sizin düzelttim dediğiniz şekilde yazıyor.
Sanırım kodları karıştırdınız...
Sanırım kodları karıştırdınız...
- Katılım
- 10 Ocak 2018
- Mesajlar
- 726
- Excel Vers. ve Dili
-
Microsoft Office 2024
Google Sheets
- Altın Üyelik Bitiş Tarihi
- 19-12-2026
Sayın @Korhan Ayhan bey. Elinize sağlık hakkınızı helal edin.
Hata benden kaynaklı kopyalarken diğer mesajdaki kodu almışım. Şuan şablon bozmadan çalışıyor.
- Katılım
- 15 Mart 2005
- Mesajlar
- 42,576
- Excel Vers. ve Dili
- Microsoft 365 Tr-En 64 Bit
Bu da biraz daha hızlı sonuç veriyor...
C++:
Option Explicit
Sub Uzlasma_Hazirla()
Dim Zaman As Double, S1 As Worksheet, S2 As Worksheet
Dim Klasor As String, Sablon As String, Word_App As Object
Dim Uzlasma As Object, Dosya As String, Veri As Variant
Dim Gecersiz_Karakter As Variant, Son As Long, X As Long, Y As Byte
Zaman = Timer
Set S1 = Sheets("Kaynak1")
Set S2 = Sheets("ProjeBilgileri")
Klasor = ThisWorkbook.Path & "\Tutanak\Uzlaşma Tutanakları\"
Sablon = ThisWorkbook.Path & "\Şablon\UZLAŞMA.docx"
On Error Resume Next
Shell ("cmd /c md " & Chr(34) & Klasor & Chr(34))
On Error GoTo 0
Son = S1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Veri = S1.Range("A2:V" & Son).Value
On Error Resume Next
Set Word_App = GetObject(, "Word.Application")
If Err.Number <> 0 Then Set Word_App = CreateObject("Word.Application")
On Error GoTo 0
For X = LBound(Veri, 1) To UBound(Veri, 1)
Set Uzlasma = Word_App.Documents.Open(Sablon)
With Uzlasma
.Bookmarks("İl").Range = Veri(X, 3)
.Bookmarks("İlçe").Range = Veri(X, 4)
.Bookmarks("Mahalle").Range = Veri(X, 5)
.Bookmarks("Ada").Range = Veri(X, 6)
.Bookmarks("Parsel").Range = Veri(X, 7)
.Bookmarks("YüzÖlçüm").Range = Veri(X, 12)
.Bookmarks("KDN").Range = Veri(X, 2)
.Bookmarks("TC").Range = Veri(X, 19)
.Bookmarks("AdıSoyadı").Range = Veri(X, 8)
.Bookmarks("AdıSoyadı2").Range = Veri(X, 8)
.Bookmarks("BabaAdı").Range = Veri(X, 9)
.Bookmarks("Cins").Range = Veri(X, 11)
.Bookmarks("DoğumTarihi").Range = Veri(X, 20)
.Bookmarks("Hissesi").Range = Veri(X, 10)
.Bookmarks("İstimlakBedel").Range = Format(Veri(X, 16), "0.00")
.Bookmarks("İrtifakBedel").Range = Format(Veri(X, 17), "0.00")
.Bookmarks("ToplamBedel").Range = Format(Veri(X, 18), "0.00")
.Bookmarks("İrtifak").Range = Format(Veri(X, 14), "0.00")
.Bookmarks("İrtifak2").Range = Format(Veri(X, 14), "0.00")
.Bookmarks("İstimlak").Range = Format(Veri(X, 13), "0.00")
.Bookmarks("İstimlak2").Range = Format(Veri(X, 13), "0.00")
.Bookmarks("TesisBilgisi").Range = S2.Cells(1, 2)
.Bookmarks("YKKTarih").Range = S2.Cells(2, 2)
.Bookmarks("YKKSayı").Range = S2.Cells(3, 2)
.Bookmarks("Baskan").Range = S2.Cells(5, 2)
.Bookmarks("BaskanU").Range = S2.Cells(6, 2)
.Bookmarks("Uye1").Range = S2.Cells(7, 2)
.Bookmarks("Uye1U").Range = S2.Cells(8, 2)
.Bookmarks("Uye2").Range = S2.Cells(9, 2)
.Bookmarks("Uye2U").Range = S2.Cells(10, 2)
Dosya = Veri(X, 2) & " - " & Veri(X, 8) & Veri(X, 10) & " (TC " & Veri(X, 19) & ")" & " (Uzlaşma)"
Gecersiz_Karakter = Array("<", ">", "|", "/", " / ", "*", ":", "\", " \ ", ".", "?", """")
For Y = LBound(Gecersiz_Karakter) To UBound(Gecersiz_Karakter)
Dosya = Replace(Dosya, Gecersiz_Karakter(Y), "_", 1)
Next
Dosya = Klasor & Dosya & ".pdf"
.ExportAsFixedFormat OutputFileName:=Dosya, _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=False, KeepIRM:=False, _
CreateBookmarks:=wdExportCreateHeadingBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=False, UseISO19005_1:=False
.Close False
End With
Next
Word_App.Quit
Set S1 = Nothing
Set S2 = Nothing
Set Word_App = Nothing
MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub- Katılım
- 10 Ocak 2018
- Mesajlar
- 726
- Excel Vers. ve Dili
-
Microsoft Office 2024
Google Sheets
- Altın Üyelik Bitiş Tarihi
- 19-12-2026
@Korhan Ayhan bey elinize sağlık çok güzel olmuş bu şekilde de..
2 kattan fazla hızlanma olduğunu düşünüyorum. Projelerde deneyip kıyaslamasını geri dönüş olarak bırakırım. Çok teşekkür ederim.
2 kattan fazla hızlanma olduğunu düşünüyorum. Projelerde deneyip kıyaslamasını geri dönüş olarak bırakırım. Çok teşekkür ederim.
- Katılım
- 10 Ocak 2018
- Mesajlar
- 726
- Excel Vers. ve Dili
-
Microsoft Office 2024
Google Sheets
- Altın Üyelik Bitiş Tarihi
- 19-12-2026
Sayın @Korhan Ayhan bey yeni kodlarınızı test ettim.
Normalde 3'dakika 48'saniye süren işlem 26saniyede tamamlandı. Resmen uçak moduna geçti proje. 10 kattan daha fazla hızlanma var.
Bu kadar hızlanacağını hiç düşünmemiştim elinize sağlık.
Daha önce hazırladığım 618 sayfa tutanaktan oluşan proje;
Normalde 1 saate yakın tamamlanmıştı.
Şuan 7 dakikada tamamlandı.
Normalde 3'dakika 48'saniye süren işlem 26saniyede tamamlandı. Resmen uçak moduna geçti proje. 10 kattan daha fazla hızlanma var.
Bu kadar hızlanacağını hiç düşünmemiştim elinize sağlık.
Daha önce hazırladığım 618 sayfa tutanaktan oluşan proje;
Normalde 1 saate yakın tamamlanmıştı.
Şuan 7 dakikada tamamlandı.
Son düzenleme:
- Katılım
- 15 Mart 2005
- Mesajlar
- 42,576
- Excel Vers. ve Dili
- Microsoft 365 Tr-En 64 Bit
Sonuçlarda doğruysa mesele yoktur. Güle güle kullanın..
- Katılım
- 10 Ocak 2018
- Mesajlar
- 726
- Excel Vers. ve Dili
-
Microsoft Office 2024
Google Sheets
- Altın Üyelik Bitiş Tarihi
- 19-12-2026
Merhaba,
Konu üzerinden biraz zaman geçti. Yeni fark ettiğim bir durum vardı yardımcı olabilir misiniz?
Kodlarda herhangi bir problem yoktur. Bazen oluşturulan evrakların mükerrer olması gerekiyor.
Yani birbiri kopyası 3 satır veri olunca sadece 1 adet dosya oluşturuyor. Daha doğrusu 3 adet oluşuyor, üzerine yazdığı için tek adet dosya oluşmuş oluyor.
Yukarıdaki kod dizinine bu düzeltme yapılabilir mi?
Aynı isimde dosya olunca sonuna (2), (3) gibi veya herhangi bir değer getirilebilir mi?
Konu üzerinden biraz zaman geçti. Yeni fark ettiğim bir durum vardı yardımcı olabilir misiniz?
Kodlarda herhangi bir problem yoktur. Bazen oluşturulan evrakların mükerrer olması gerekiyor.
Yani birbiri kopyası 3 satır veri olunca sadece 1 adet dosya oluşturuyor. Daha doğrusu 3 adet oluşuyor, üzerine yazdığı için tek adet dosya oluşmuş oluyor.
Yukarıdaki kod dizinine bu düzeltme yapılabilir mi?
Aynı isimde dosya olunca sonuna (2), (3) gibi veya herhangi bir değer getirilebilir mi?
- Katılım
- 15 Mart 2005
- Mesajlar
- 42,576
- Excel Vers. ve Dili
- Microsoft 365 Tr-En 64 Bit
Deneyiniz.
C++:
Option Explicit
Sub Uzlasma_Hazirla()
Dim Zaman As Double, S1 As Worksheet, S2 As Worksheet, Dizi As Object
Dim Klasor As String, Sablon As String, Word_App As Object, FSO As Object
Dim Uzlasma As Object, Dosya As String, Veri As Variant
Dim Gecersiz_Karakter As Variant, Son As Long, X As Long, Y As Byte
Zaman = Timer
Set S1 = Sheets("Kaynak1")
Set S2 = Sheets("ProjeBilgileri")
Set Dizi = VBA.CreateObject("Scripting.Dictionary")
Set FSO = VBA.CreateObject("Scripting.FileSystemObject")
Klasor = ThisWorkbook.Path & "\Tutanak\Uzlaşma Tutanakları\"
Sablon = ThisWorkbook.Path & "\Şablon\UZLAŞMA.docx"
On Error Resume Next
Shell ("cmd /c md " & Chr(34) & Klasor & Chr(34))
On Error GoTo 0
Son = S1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Veri = S1.Range("A2:V" & Son).Value
On Error Resume Next
Set Word_App = GetObject(, "Word.Application")
If Err.Number <> 0 Then Set Word_App = CreateObject("Word.Application")
On Error GoTo 0
For X = LBound(Veri, 1) To UBound(Veri, 1)
Set Uzlasma = Word_App.Documents.Open(Sablon)
With Uzlasma
.Bookmarks("İl").Range = Veri(X, 3)
.Bookmarks("İlçe").Range = Veri(X, 4)
.Bookmarks("Mahalle").Range = Veri(X, 5)
.Bookmarks("Ada").Range = Veri(X, 6)
.Bookmarks("Parsel").Range = Veri(X, 7)
.Bookmarks("YüzÖlçüm").Range = Veri(X, 12)
.Bookmarks("KDN").Range = Veri(X, 2)
.Bookmarks("TC").Range = Veri(X, 19)
.Bookmarks("AdıSoyadı").Range = Veri(X, 8)
.Bookmarks("AdıSoyadı2").Range = Veri(X, 8)
.Bookmarks("BabaAdı").Range = Veri(X, 9)
.Bookmarks("Cins").Range = Veri(X, 11)
.Bookmarks("DoğumTarihi").Range = Veri(X, 20)
.Bookmarks("Hissesi").Range = Veri(X, 10)
.Bookmarks("İstimlakBedel").Range = Format(Veri(X, 16), "0.00")
.Bookmarks("İrtifakBedel").Range = Format(Veri(X, 17), "0.00")
.Bookmarks("ToplamBedel").Range = Format(Veri(X, 18), "0.00")
.Bookmarks("İrtifak").Range = Format(Veri(X, 14), "0.00")
.Bookmarks("İrtifak2").Range = Format(Veri(X, 14), "0.00")
.Bookmarks("İstimlak").Range = Format(Veri(X, 13), "0.00")
.Bookmarks("İstimlak2").Range = Format(Veri(X, 13), "0.00")
.Bookmarks("TesisBilgisi").Range = S2.Cells(1, 2)
.Bookmarks("YKKTarih").Range = S2.Cells(2, 2)
.Bookmarks("YKKSayı").Range = S2.Cells(3, 2)
.Bookmarks("Baskan").Range = S2.Cells(5, 2)
.Bookmarks("BaskanU").Range = S2.Cells(6, 2)
.Bookmarks("Uye1").Range = S2.Cells(7, 2)
.Bookmarks("Uye1U").Range = S2.Cells(8, 2)
.Bookmarks("Uye2").Range = S2.Cells(9, 2)
.Bookmarks("Uye2U").Range = S2.Cells(10, 2)
Dosya = Veri(X, 2) & " - " & Veri(X, 8) & Veri(X, 10) & " (TC " & Veri(X, 19) & ")" & " (Uzlaşma)"
Gecersiz_Karakter = Array("<", ">", "|", "/", " / ", "*", ":", "\", " \ ", ".", "?", """")
For Y = LBound(Gecersiz_Karakter) To UBound(Gecersiz_Karakter)
Dosya = Replace(Dosya, Gecersiz_Karakter(Y), "_", 1)
Next
Dosya = Klasor & Dosya & ".pdf"
If Not Dizi.Exists(Dosya) Then
Dizi.Add Dosya, 0
Else
10 Dizi.Item(Dosya) = Dizi.Item(Dosya) + 1
Dosya = Klasor & FSO.GetBaseName(Dosya) & "_" & _
Dizi.Item(Dosya) & "." & FSO.GetExtensionName(Dosya)
End If
If Dir(Dosya) <> "" Then GoTo 10
.ExportAsFixedFormat OutputFileName:=Dosya, _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=False, KeepIRM:=False, _
CreateBookmarks:=wdExportCreateHeadingBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=False, UseISO19005_1:=False
.Close False
End With
Next
Word_App.Quit
Dizi.RemoveAll
Set S1 = Nothing
Set S2 = Nothing
Set Word_App = Nothing
Set Dizi = Nothing
Set FSO = Nothing
MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub- Katılım
- 10 Ocak 2018
- Mesajlar
- 726
- Excel Vers. ve Dili
-
Microsoft Office 2024
Google Sheets
- Altın Üyelik Bitiş Tarihi
- 19-12-2026
Sayın @Korhan Ayhan üstadım. Emeğinize sağlık. Verileri çoğaltıp denedim sonuç resimdeki gibi.
Teşekkür ederim.
ruhadam26
Altın Üye
- Katılım
- 4 Aralık 2017
- Mesajlar
- 117
- Excel Vers. ve Dili
- 2010-2016 türkçe
- Altın Üyelik Bitiş Tarihi
- 20-12-2025
Merhaba hocam bunu pdf olarak değilde word olarak keydedilmesini istiyorsak nasil bir yol izlemeliyiz. .pdf yazan yeri .docx olarak değiştiridğimde word dosyları oluşuyor ama hatalı word oluşuyor açılmıyor.
- Katılım
- 15 Mart 2005
- Mesajlar
- 42,576
- Excel Vers. ve Dili
- Microsoft 365 Tr-En 64 Bit
Şu satırları silip;
Yerine aşağıdaki satıları ekleyip deneyiniz.
C++:
Dosya = Klasor & Dosya & ".pdf"
.ExportAsFixedFormat OutputFileName:=Dosya, _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=False, KeepIRM:=False, _
CreateBookmarks:=wdExportCreateHeadingBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=False, UseISO19005_1:=False
C++:
Dosya = Klasor & Dosya & ".docx"
ActiveDocument.SaveAs2 FileName:=Dosya _
, FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
:=False, SaveAsAOCELetter:=False, CompatibilityMode:=15ruhadam26
Altın Üye
- Katılım
- 4 Aralık 2017
- Mesajlar
- 117
- Excel Vers. ve Dili
- 2010-2016 türkçe
- Altın Üyelik Bitiş Tarihi
- 20-12-2025
Allah sizden razı olsun elinize emeğinize sağlık teşekkürler
Merhaba, elimde 100 satırlık excel var bunu worde aktarmak istiyorum. Buradan yola çıkarak bir yere kadar geldim. Şu an sorunum tek satır olarak attı. İşime yaracak olan exceldeki 100 satırı 100 sayfa seklınde worde aktarmak. Yaptığım işlem ;+
NOT: Bunu yapmak istemem bir ayakkabı firmasında calısıyorum bilgiler excelden gelıyor. Etiket çıkarmak için worde tasarım yaptım. Tek sefer tüm içeriği aktarık barkod yazıcıdan cıkarmak ıstıyorum.
Private Sub CommandButton1_Click()
Dim doc As Word.Document
Set wordapp = CreateObject("word.application")
sablon = "C:\Users\ismail\Desktop\Test\sablon.docx"
For i = 2 To 110
Set doc = wordapp.Documents.Open(sablon)
doc.Bookmarks("KALITE").Range.InsertAfter Cells(i, 1)
doc.Bookmarks("MODEL").Range.InsertAfter Cells(i, 2)
doc.Bookmarks("RENK").Range.InsertAfter Cells(i, 3)
doc.Bookmarks("KIRK").Range.InsertAfter Cells(i, 4)
doc.Bookmarks("KIRKBIR").Range.InsertAfter Cells(i, 5)
doc.Bookmarks("KIRKIKI").Range.InsertAfter Cells(i, 6)
doc.Bookmarks("KIRKUC").Range.InsertAfter Cells(i, 7)
doc.Bookmarks("KIRKDORT").Range.InsertAfter Cells(i, 8)
doc.Bookmarks("KIRKBES").Range.InsertAfter Cells(i, 9)
doc.Bookmarks("Toplam").Range.InsertAfter Cells(i, 10)
doc.Bookmarks("MKOD").Range.InsertAfter Cells(i, 11)
doc.SaveAs2 "C:\Users\ismail\Desktop\Test\test.docx"
Next i
End Sub
NOT: Bunu yapmak istemem bir ayakkabı firmasında calısıyorum bilgiler excelden gelıyor. Etiket çıkarmak için worde tasarım yaptım. Tek sefer tüm içeriği aktarık barkod yazıcıdan cıkarmak ıstıyorum.
Private Sub CommandButton1_Click()
Dim doc As Word.Document
Set wordapp = CreateObject("word.application")
sablon = "C:\Users\ismail\Desktop\Test\sablon.docx"
For i = 2 To 110
Set doc = wordapp.Documents.Open(sablon)
doc.Bookmarks("KALITE").Range.InsertAfter Cells(i, 1)
doc.Bookmarks("MODEL").Range.InsertAfter Cells(i, 2)
doc.Bookmarks("RENK").Range.InsertAfter Cells(i, 3)
doc.Bookmarks("KIRK").Range.InsertAfter Cells(i, 4)
doc.Bookmarks("KIRKBIR").Range.InsertAfter Cells(i, 5)
doc.Bookmarks("KIRKIKI").Range.InsertAfter Cells(i, 6)
doc.Bookmarks("KIRKUC").Range.InsertAfter Cells(i, 7)
doc.Bookmarks("KIRKDORT").Range.InsertAfter Cells(i, 8)
doc.Bookmarks("KIRKBES").Range.InsertAfter Cells(i, 9)
doc.Bookmarks("Toplam").Range.InsertAfter Cells(i, 10)
doc.Bookmarks("MKOD").Range.InsertAfter Cells(i, 11)
doc.SaveAs2 "C:\Users\ismail\Desktop\Test\test.docx"
Next i
End Sub
- Katılım
- 15 Mart 2005
- Mesajlar
- 42,576
- Excel Vers. ve Dili
- Microsoft 365 Tr-En 64 Bit
Örnek dosyalarınızı paylaşabilirmisiniz.
Merhaba dosyayı wetransfer üzerinden kaydettim https://we.tl/t-BO02hbd0I0