Grupta istenen eleman yok hatası

hadromer · 26 Ağustos 2019

Merhaba,
Bir kaç gün önce https://www.excel.web.tr/threads/word-sabit-bir-tablo-olusturup-icerisine-fotograf-eklemek.181729/ açtığım bu konuda @halit3 hocam çok yardımcı olmuştu. Yazdığı kod tam istediğim işlevde. Lakin kodu çalıştırınca yarısına gelince " run time error 5941, grupta istenen eleman yok" hatası alıyorum. Şöyle ilave edeyim ; 6 ayrı word dosyam var. 6 dosyayı tek bir klasöre kopyaladım. ilk iki dosyada çok güzel çalışıyor. sırasıyla dosyaları açıp resimleri içinden çekiyor. 3 numaralı dosyaya gelince yarısına kadar çekiyor ve belli bir yerde yukarıdaki hatayı veriyor. hata veren resmi sildim öyle denedim, bu seferde bir sonraki resimde takıldı. 3 numaralı dosyayı tek başına kod ile çalıştırdım yine hata aldım. Dosyayı kopyalayıp yeni bir word dosyasına kaydettim yine olmadı. Acaba sorun neden olabilir ?

halit3 · 26 Ağustos 2019

Dosyalarınızdaki sayfalar aynı ise en son güncellediğim kodu yeniden deneyiniz.

Kod:

'referanslar
'Microsoft Word 12.0 Object Library

Sub deneme6()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla

Dim fL As Object, fs As Object
Set fL = CreateObject("Scripting.FileSystemObject")

sat1 = 1
sut1 = 1
say1 = 3
yuk = 255 '165
  
Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Add
wrdApp.Visible = True

With wrdApp.ActiveDocument.PageSetup
.LeftMargin = 30 '50 'sol
.RightMargin = 10 '50 'sağ
.TopMargin = 20 'üst
.BottomMargin = 20 '20 ' alt
.Orientation = wdOrientLandscape
End With

wrdApp.ActiveDocument.Tables.Add Range:=wrdApp.ActiveDocument.Range(0, 0), NumRows:=2, NumColumns:=say1

Application.WindowState = wdWindowStateMinimize

For Each Dosya In fL.GetFolder(Kaynak).Files
uzanti = fL.GetExtensionName(Dosya)
If uzanti = "doc" Or uzanti = "docx" Then

yol = Dosya

Dim objWord As Word.Application
Dim docWord As Word.Document
Dim ImgItem As Word.InlineShape
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set docWord = objWord.Documents.Open(Filename:=yol, ReadOnly:=True)

'On Error Resume Next
sat2 = 1
deg2 = 1

For Each ImgItem In docWord.InlineShapes
If ImgItem.Type = wdInlineShapePicture Then
bulunan2 = Trim(Replace(Replace(objWord.ActiveDocument.Tables.Item(sat2).Cell(7, 2).Range.Text, "", ""), Chr(13), ""))
sat2 = sat2 + 2
'objWord.ActiveDocument.InlineShapes.Item(deg2).Range.CopyAsPicture
ImgItem.Select
objWord.Selection.CopyAsPicture
deg2 = deg2 + 1

'----------------------------------------------------
wrdApp.ActiveDocument.Tables.Item(1).Cell(sat1 + 1, sut1).Range = bulunan2
wrdApp.ActiveDocument.Tables.Item(1).Cell(sat1 + 1, sut1).Range.Select

With wrdApp.ActiveDocument.Tables.Item(1).Cell(sat1, sut1)
.Range.Paragraphs.WordWrap = True
.Range.Paste
.Range.InlineShapes(1).Fill.Visible = msoFalse
.Range.InlineShapes(1).Fill.Solid
.Range.InlineShapes(1).Line.Visible = msoFalse
.Range.InlineShapes(1).Height = yuk
.Range.InlineShapes(1).Width = .Range.Cells.Width - 6
End With

sut1 = sut1 + 1
If sut1 = say1 + 1 Then
sut1 = 1
sat1 = sat1 + 2
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Select
wrdApp.Selection.InsertRowsBelow 2
End If
'-------------------------------------------------------
End If
Next

ThisWorkbook.Sheets(ActiveSheet.Name).Range("a1").Copy
Application.CutCopyMode = False
docWord.Close SaveChanges:=wdPromptToSaveChanges
objWord.Quit
Set docWord = Nothing

End If
Next

If sut1 = 1 Then
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Delete
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Delete
End If
Klasor = ThisWorkbook.Path & "\yeni"

If fL.FolderExists(Klasor) = False Then
MkDir Klasor
End If

son1 = fL.GetFolder(Klasor).Files.Count + 1
dosya_adi = Klasor & "\" & "word dosya" & son1 & ".doc"
wrdApp.ActiveDocument.SaveAs dosya_adi
wrdApp.Quit


Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

End Sub

hadromer · 26 Ağustos 2019

halit3' Alıntı:

Dosyalarınızdaki sayfalar aynı ise en son güncellediğim kodu yeniden deneyiniz.

Kod:

'referanslar
'Microsoft Word 12.0 Object Library

Sub deneme6()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla

Dim fL As Object, fs As Object
Set fL = CreateObject("Scripting.FileSystemObject")

sat1 = 1
sut1 = 1
say1 = 3
yuk = 255 '165

Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Add
wrdApp.Visible = True

With wrdApp.ActiveDocument.PageSetup
.LeftMargin = 30 '50 'sol
.RightMargin = 10 '50 'sağ
.TopMargin = 20 'üst
.BottomMargin = 20 '20 ' alt
.Orientation = wdOrientLandscape
End With

wrdApp.ActiveDocument.Tables.Add Range:=wrdApp.ActiveDocument.Range(0, 0), NumRows:=2, NumColumns:=say1

Application.WindowState = wdWindowStateMinimize

For Each Dosya In fL.GetFolder(Kaynak).Files
uzanti = fL.GetExtensionName(Dosya)
If uzanti = "doc" Or uzanti = "docx" Then

yol = Dosya

Dim objWord As Word.Application
Dim docWord As Word.Document
Dim ImgItem As Word.InlineShape
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set docWord = objWord.Documents.Open(Filename:=yol, ReadOnly:=True)

'On Error Resume Next
sat2 = 1
deg2 = 1

For Each ImgItem In docWord.InlineShapes
If ImgItem.Type = wdInlineShapePicture Then
bulunan2 = Trim(Replace(Replace(objWord.ActiveDocument.Tables.Item(sat2).Cell(7, 2).Range.Text, "", ""), Chr(13), ""))
sat2 = sat2 + 2
'objWord.ActiveDocument.InlineShapes.Item(deg2).Range.CopyAsPicture
ImgItem.Select
objWord.Selection.CopyAsPicture
deg2 = deg2 + 1

'----------------------------------------------------
wrdApp.ActiveDocument.Tables.Item(1).Cell(sat1 + 1, sut1).Range = bulunan2
wrdApp.ActiveDocument.Tables.Item(1).Cell(sat1 + 1, sut1).Range.Select

With wrdApp.ActiveDocument.Tables.Item(1).Cell(sat1, sut1)
.Range.Paragraphs.WordWrap = True
.Range.Paste
.Range.InlineShapes(1).Fill.Visible = msoFalse
.Range.InlineShapes(1).Fill.Solid
.Range.InlineShapes(1).Line.Visible = msoFalse
.Range.InlineShapes(1).Height = yuk
.Range.InlineShapes(1).Width = .Range.Cells.Width - 6
End With

sut1 = sut1 + 1
If sut1 = say1 + 1 Then
sut1 = 1
sat1 = sat1 + 2
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Select
wrdApp.Selection.InsertRowsBelow 2
End If
'-------------------------------------------------------
End If
Next

ThisWorkbook.Sheets(ActiveSheet.Name).Range("a1").Copy
Application.CutCopyMode = False
docWord.Close SaveChanges:=wdPromptToSaveChanges
objWord.Quit
Set docWord = Nothing

End If
Next

If sut1 = 1 Then
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Delete
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Delete
End If
Klasor = ThisWorkbook.Path & "\yeni"

If fL.FolderExists(Klasor) = False Then
MkDir Klasor
End If

son1 = fL.GetFolder(Klasor).Files.Count + 1
dosya_adi = Klasor & "\" & "word dosya" & son1 & ".doc"
wrdApp.ActiveDocument.SaveAs dosya_adi
wrdApp.Quit


Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

End Sub

her bir dosyam farklı sayfa numaralarına sahip. birisi 200, birisi 96 gibi. son veridiğiniz kodlarda yukarıdaki hatayı alıyorum. excel'de düğme ekleyip denedim yine aynı. Bir önceki kodunuz muazzam çalışıyor ama 3 numaralı dosyamda takılıyor.

hadromer · 26 Ağustos 2019

@halit3 hocam tamam. 3 tane fotoğrafta sıkıntı varmış sanırım. onları silince bu dosya da da çalıştı. Son verdiğiniz kod değil bir önceki muazzam çalışıyor

hadromer · 26 Ağustos 2019

şöyle de bir hata farkettim. hata veren kısmı incelediğimde fotoğrafın altında, olması gereken isimden bir önceki isim var.

hadromer · 26 Ağustos 2019

@halit3 hocam bakın hata bu. bir fotonun altındaki ismi almıyor, dolayısıyla fotoğraflar normal ama isimler kayıyor. böyle olunca da çekme işlemini durduruyor sanırım.

halit3 · 26 Ağustos 2019

Bu kadu dene
kodun işleyişi resim nesnesinin adını önce hafızaya alıyor sonra da resimi kopyaladığında resim adını yazdırıyor bu durum da kod zaman olarak tam iki kat uzadı.

Kod:

'referanslar
'Microsoft Word 12.0 Object Library

Sub deneme5()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla

Dim fL As Object, fs As Object
Set fL = CreateObject("Scripting.FileSystemObject")

sat1 = 1
sut1 = 1
say1 = 3
yuk = 220 '165
  
Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Add
wrdApp.Visible = True

With wrdApp.ActiveDocument.PageSetup
.LeftMargin = 30 '50 'sol
.RightMargin = 10 '50 'sağ
.TopMargin = 20 'üst
.BottomMargin = 20 '20 ' alt
.Orientation = wdOrientLandscape
End With

wrdApp.ActiveDocument.Tables.Add Range:=wrdApp.ActiveDocument.Range(0, 0), NumRows:=2, NumColumns:=say1

Application.WindowState = wdWindowStateMinimize

For Each Dosya In fL.GetFolder(Kaynak).Files
uzanti = fL.GetExtensionName(Dosya)
If uzanti = "doc" Or uzanti = "docx" Then

yol = Dosya
ReDim veri(5000)
Dim objWord As Word.Application
Dim docWord As Word.Document
Dim ImgItem As Word.InlineShape
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set docWord = objWord.Documents.Open(Filename:=yol, ReadOnly:=True)

sayy1 = 0

If objWord.ActiveDocument.Tables.Count > 0 Then
For i = 1 To objWord.ActiveDocument.Tables.Count
aranan = "Tür / Species"
satson = objWord.ActiveDocument.Tables(1).Rows.Count
sutson = objWord.ActiveDocument.Tables(1).Columns.Count

For r = 1 To objWord.ActiveDocument.Tables(i).Rows.Count
bulunan = objWord.ActiveDocument.Tables.Item(i).Cell(r, 1).Range.Text
k = InStr(1, bulunan, aranan)
If k > 0 Then
bulunan2 = Trim(Replace(Replace(objWord.ActiveDocument.Tables.Item(i).Cell(r, 2).Range.Text, "", ""), Chr(13), ""))
sayy1 = sayy1 + 1
veri(sayy1) = bulunan2
GoTo atla3
End If
Next r
atla3:
Next i
End If


'On Error Resume Next
sat2 = 1
deg2 = 0

For Each ImgItem In docWord.InlineShapes
If ImgItem.Type = wdInlineShapePicture Then
'bulunan2 = Trim(Replace(Replace(objWord.ActiveDocument.Tables.Item(sat2).Cell(7, 2).Range.Text, "", ""), Chr(13), ""))
'sat2 = sat2 + 2
'objWord.ActiveDocument.InlineShapes.Item(deg2).Range.CopyAsPicture
deg2 = deg2 + 1
wrdApp.ActiveDocument.Tables.Item(1).Cell(sat1 + 1, sut1).Range = veri(deg2)
wrdApp.ActiveDocument.Tables.Item(1).Cell(sat1 + 1, sut1).Range.Select


ImgItem.Select
objWord.Selection.CopyAsPicture

'----------------------------------------------------


With wrdApp.ActiveDocument.Tables.Item(1).Cell(sat1, sut1)
.Range.Paragraphs.WordWrap = True
.Range.Paste
.Range.InlineShapes(1).Fill.Visible = msoFalse
.Range.InlineShapes(1).Fill.Solid
.Range.InlineShapes(1).Line.Visible = msoFalse
.Range.InlineShapes(1).Height = yuk
.Range.InlineShapes(1).Width = .Range.Cells.Width - 6
End With

sut1 = sut1 + 1
If sut1 = say1 + 1 Then
sut1 = 1
sat1 = sat1 + 2
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Select
wrdApp.Selection.InsertRowsBelow 2
End If
'-------------------------------------------------------
End If
Next

ThisWorkbook.Sheets(ActiveSheet.Name).Range("a1").Copy
Application.CutCopyMode = False
docWord.Close SaveChanges:=wdPromptToSaveChanges
objWord.Quit
Set docWord = Nothing

End If
Next

If sut1 = 1 Then
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Delete
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Delete
End If
Klasor = ThisWorkbook.Path & "\yeni"

If fL.FolderExists(Klasor) = False Then
MkDir Klasor
End If

son1 = fL.GetFolder(Klasor).Files.Count + 1
dosya_adi = Klasor & "\" & "word dosya" & son1 & ".doc"
wrdApp.ActiveDocument.SaveAs dosya_adi
wrdApp.Quit


Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

End Sub

halit3 · 26 Ağustos 2019

şunuda söylüyüm dosyada bu kadar çok resim ekleyince dosya çalışmayabilir çünkü kapasitesinden çok resim ekleniyor ben yaptım dosyanın boyutu 51878 kb olmuş

hadromer · 26 Ağustos 2019

halit3' Alıntı:
şunuda söylüyüm dosyada bu kadar çok resim ekleyince dosya çalışmayabilir çünkü kapasitesinden çok resim ekleniyor ben yaptım dosyanın boyutu 51878 kb olmuş

siz 6 dosyayıda mı çalıştırdınız ? yani sizde oluyor mu ?
son verdiğiniz kodu denedim compile error veriyor yine. dosyalara tek tek uyguluyorum hocam formulü..

halit3 · 26 Ağustos 2019

son gönderdiğim kod buraya eklediğin 6 dosyayı da birleştirdi

hadromer · 26 Ağustos 2019

halit3' Alıntı:
son gönderdiğim kod buraya eklediğin 6 dosyayı da birleştirdi

hocam bende neden olmuyor çok moralim bozuldu. o dosya duruyorsa upload edebilir misiniz

halit3 · 26 Ağustos 2019

yukarıdaki mesajımda da yazmıştım süre iki katına kadar uzadı kod önce okuyor sonra yazıyor birazcık beklemek gerekiyor.

hadromer · 26 Ağustos 2019

hocam bende neden bu hatalar çıkıyor ? excelde gösterdiğiniz gibi düğme oluşturup denedim yine hata alıyorum. aşağıda gif te görüldüğü üzere wordde deniyorum başlatmıyor.

halit3 · 26 Ağustos 2019

Sen kodları word dosyasının içine almışın kodlar excel dosyasının madüle içinde olacak

halit3 · 26 Ağustos 2019

önceki kanuda da yazmıştım makro bilginiz ne kadarsa o kadar işlem yaparsınız size tavsiyem makroların nereye yazıldığı ve komut düğmelerine nasıl bağlandığını öğrenin yoksa size bu tür kod yazanların makrolarını çalıştıramazsınız.

halit3 · 26 Ağustos 2019

İmza bölümümde
Ofis 2007 için makro güvenlik ayarları
http://www.excel.web.tr/f157/ofis-2007-yi-ilk-kullananlar-icin-makro-guvenlik-t104852.html
bunu öncelikle yapın
şunları bilmeniz gerekiyor excel dosyalarında makrolar xlsm ve xls uzantılarında çalışmaktadır yeni oluşturduğunuz excel dosyalarını farklı kayıt yaparak bu uzantılara farklı kayıt yapmalısınız yoksa makrolar kaybolur.

halit3 · 26 Ağustos 2019

herhalde yapamıyacaksınız TeamViewer ile bağlanalım

halit3 · 27 Ağustos 2019

Bu kod birazcık daha hızlı beklemek yok.

Kod:

'referanslar
'Microsoft Word 12.0 Object Library

Sub deneme7()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla

Dim fL As Object, fs As Object
Set fL = CreateObject("Scripting.FileSystemObject")

sat1 = 1
sut1 = 1
say1 = 3
yuk = 255 '165

Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Add
wrdApp.Visible = True

With wrdApp.ActiveDocument.PageSetup
.LeftMargin = 30 '50 'sol
.RightMargin = 10 '50 'sağ
.TopMargin = 20 'üst
.BottomMargin = 20 '20 ' alt
.Orientation = wdOrientLandscape
End With

wrdApp.ActiveDocument.Tables.Add Range:=wrdApp.ActiveDocument.Range(0, 0), NumRows:=2, NumColumns:=say1

Application.WindowState = wdWindowStateMinimize

For Each Dosya In fL.GetFolder(Kaynak).Files
uzanti = fL.GetExtensionName(Dosya)
If uzanti = "doc" Or uzanti = "docx" Then

yol = Dosya

Dim objWord As Word.Application
Dim docWord As Word.Document
Dim ImgItem As Word.InlineShape
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set docWord = objWord.Documents.Open(Filename:=yol, ReadOnly:=True)

'On Error Resume Next
sat2 = 0
deg2 = 1

For Each ImgItem In docWord.InlineShapes
If ImgItem.Type = wdInlineShapePicture Then
sat2 = sat2 + 1
atla3:
If objWord.ActiveDocument.Tables.Count >= sat2 Then
If objWord.ActiveDocument.Tables(sat2).Rows.Count > 2 Then
bulunan2 = Trim(Replace(Replace(objWord.ActiveDocument.Tables.Item(sat2).Cell(7, 2).Range.Text, "", ""), Chr(13), ""))
Else
sat2 = sat2 + 1
GoTo atla3
End If
End If

'objWord.ActiveDocument.InlineShapes.Item(deg2).Range.CopyAsPicture
ImgItem.Select
objWord.Selection.CopyAsPicture
deg2 = deg2 + 1

'----------------------------------------------------
wrdApp.ActiveDocument.Tables.Item(1).Cell(sat1 + 1, sut1).Range = bulunan2
wrdApp.ActiveDocument.Tables.Item(1).Cell(sat1 + 1, sut1).Range.Select

With wrdApp.ActiveDocument.Tables.Item(1).Cell(sat1, sut1)
.Range.Paragraphs.WordWrap = True
.Range.Paste
.Range.InlineShapes(1).Fill.Visible = msoFalse
.Range.InlineShapes(1).Fill.Solid
.Range.InlineShapes(1).Line.Visible = msoFalse
.Range.InlineShapes(1).Height = yuk
.Range.InlineShapes(1).Width = .Range.Cells.Width - 6
End With

sut1 = sut1 + 1
If sut1 = say1 + 1 Then
sut1 = 1
sat1 = sat1 + 2
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Select
wrdApp.Selection.InsertRowsBelow 2
End If
'-------------------------------------------------------
End If
Next

ThisWorkbook.Sheets(ActiveSheet.Name).Range("a1").Copy
Application.CutCopyMode = False
docWord.Close SaveChanges:=wdPromptToSaveChanges
objWord.Quit
Set docWord = Nothing

End If
Next

If sut1 = 1 Then
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Delete
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Delete
End If
Klasor = ThisWorkbook.Path & "\yeni"

If fL.FolderExists(Klasor) = False Then
MkDir Klasor
End If

son1 = fL.GetFolder(Klasor).Files.Count + 1
dosya_adi = Klasor & "\" & "word dosya" & son1 & ".doc"
wrdApp.ActiveDocument.SaveAs dosya_adi
wrdApp.Quit


Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

End Sub

hadromer · 27 Ağustos 2019

halit3' Alıntı:

Bu kod birazcık daha hızlı beklemek yok.

Kod:

'referanslar
'Microsoft Word 12.0 Object Library

Sub deneme7()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla

Dim fL As Object, fs As Object
Set fL = CreateObject("Scripting.FileSystemObject")

sat1 = 1
sut1 = 1
say1 = 3
yuk = 255 '165

Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Add
wrdApp.Visible = True

With wrdApp.ActiveDocument.PageSetup
.LeftMargin = 30 '50 'sol
.RightMargin = 10 '50 'sağ
.TopMargin = 20 'üst
.BottomMargin = 20 '20 ' alt
.Orientation = wdOrientLandscape
End With

wrdApp.ActiveDocument.Tables.Add Range:=wrdApp.ActiveDocument.Range(0, 0), NumRows:=2, NumColumns:=say1

Application.WindowState = wdWindowStateMinimize

For Each Dosya In fL.GetFolder(Kaynak).Files
uzanti = fL.GetExtensionName(Dosya)
If uzanti = "doc" Or uzanti = "docx" Then

yol = Dosya

Dim objWord As Word.Application
Dim docWord As Word.Document
Dim ImgItem As Word.InlineShape
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set docWord = objWord.Documents.Open(Filename:=yol, ReadOnly:=True)

'On Error Resume Next
sat2 = 0
deg2 = 1

For Each ImgItem In docWord.InlineShapes
If ImgItem.Type = wdInlineShapePicture Then
sat2 = sat2 + 1
atla3:
If objWord.ActiveDocument.Tables.Count >= sat2 Then
If objWord.ActiveDocument.Tables(sat2).Rows.Count > 2 Then
bulunan2 = Trim(Replace(Replace(objWord.ActiveDocument.Tables.Item(sat2).Cell(7, 2).Range.Text, "", ""), Chr(13), ""))
Else
sat2 = sat2 + 1
GoTo atla3
End If
End If

'objWord.ActiveDocument.InlineShapes.Item(deg2).Range.CopyAsPicture
ImgItem.Select
objWord.Selection.CopyAsPicture
deg2 = deg2 + 1

'----------------------------------------------------
wrdApp.ActiveDocument.Tables.Item(1).Cell(sat1 + 1, sut1).Range = bulunan2
wrdApp.ActiveDocument.Tables.Item(1).Cell(sat1 + 1, sut1).Range.Select

With wrdApp.ActiveDocument.Tables.Item(1).Cell(sat1, sut1)
.Range.Paragraphs.WordWrap = True
.Range.Paste
.Range.InlineShapes(1).Fill.Visible = msoFalse
.Range.InlineShapes(1).Fill.Solid
.Range.InlineShapes(1).Line.Visible = msoFalse
.Range.InlineShapes(1).Height = yuk
.Range.InlineShapes(1).Width = .Range.Cells.Width - 6
End With

sut1 = sut1 + 1
If sut1 = say1 + 1 Then
sut1 = 1
sat1 = sat1 + 2
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Select
wrdApp.Selection.InsertRowsBelow 2
End If
'-------------------------------------------------------
End If
Next

ThisWorkbook.Sheets(ActiveSheet.Name).Range("a1").Copy
Application.CutCopyMode = False
docWord.Close SaveChanges:=wdPromptToSaveChanges
objWord.Quit
Set docWord = Nothing

End If
Next

If sut1 = 1 Then
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Delete
wrdApp.ActiveDocument.Sections(1).Range.Tables(1).Rows.Last.Delete
End If
Klasor = ThisWorkbook.Path & "\yeni"

If fL.FolderExists(Klasor) = False Then
MkDir Klasor
End If

son1 = fL.GetFolder(Klasor).Files.Count + 1
dosya_adi = Klasor & "\" & "word dosya" & son1 & ".doc"
wrdApp.ActiveDocument.SaveAs dosya_adi
wrdApp.Quit


Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

End Sub

hocam nasıl teşekkür edeceğimi şaşırdım, elinize sağlık. Çok minnettarım. Sizin bu yardımseverliğinize karşın bende altın üye oldum. Çok teşekkür ediyoprum

halit3 · 27 Ağustos 2019

kod resim ve adını bazen eşliştirmiyor.

Grupta istenen eleman yok hatası

hadromer

halit3

Uzman

hadromer

hadromer

hadromer

hadromer

halit3

Uzman

halit3

Uzman

hadromer

halit3

Uzman

hadromer

halit3

Uzman

hadromer

halit3

Uzman

halit3

Uzman

halit3

Uzman

halit3

Uzman

halit3

Uzman

hadromer

halit3

Uzman