• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Word'de ki TextBox'dan Excel'e Veri Aktarma

R

ridvanucok

Katılım
10 Mart 2013
Mesajlar
187
Excel Vers. ve Dili
2016 - İngilizce
Arkadaşlar merhaba,

Ekte örnek cevap yazısı mevcuttur. Ekli örnek yazısında Ad Soyad, Ünvan, Kurum Adı ve Kurum Adresi yazan bilgileri (KIRMIZI İLE BELİRTİLEN BİLGİLER) excel'e aktarabilir miyim? Birden fazla cevap yazısını bir klasöre alarak, tüm cevap yazılarındaki belirtilen bilgileri excel'e sırası ile aktarmak istiyorum. Bunu yapmamdaki amaç ise cevap yazılarını kurumlara kargo ile gönderiyoruz, kargoların üzerine manuel olarak Ad Soyad, Ünvan, Kurum Adı ve Kurum Adresi yazıyoruz. Manuel olarak yazmak yerine hepsini excel'e alarak, wordde mailings kullanıp etikete çıkartarak, zamandan kazanmak istiyorum.
 

Ekli dosyalar

Son düzenleme:
excelden aldığım veriyle çarpma işlemi

excel vba ortamında userfrom üzerine textbox yerleştirdim
hesaplama yap butonuna basınca excel sayfa1 deki d17 sutunundaki değerle textbox değerini çarpmasını istiyorum yardımcı olabilirmisiniz ?
şimdiden teşekkürler ..
 
salihhtr' Alıntı:
excel vba ortamında userfrom üzerine textbox yerleştirdim
hesaplama yap butonuna basınca excel sayfa1 deki d17 sutunundaki değerle textbox değerini çarpmasını istiyorum yardımcı olabilirmisiniz ?
şimdiden teşekkürler ..
Genişletmek için tıkla ...


Merhaba,

Yeni bir konu oluşturup örnek dosyaları da konunuza ekledikten sonra, özelden konu linkini iletirseniz yardımcı olmaya çalışayım. Hatta asri üstadımın hazırladığı http://asriakdeniz.com/excel-adres-etiket-yazdirma-programi/ programını da inceleyebilirsin. Belki işine yarar. (y)

İyi çalışmalar.
 
Dosyada referanslarda
Kod: 
'Microsoft word 12.0 object library

bu olmalı ayrıca örnek word dosya veri alınacak dosyanın yanında olmalı

Kod: 
Sub deneme()
'referanslar
'Microsoft word 12.0 object library

Dim objWord As Word.Application
Dim docWord As Word.Document
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
yol = ActiveWorkbook.Path & "\[COLOR="Red"]ÖRNEK CEVAP YAZISI.doc[/COLOR]"
Set docWord = objWord.Documents.Open(Filename:=yol, ReadOnly:=True)
Application.WindowState = wdWindowStateMinimize
'Application.WindowState = wdWindowStateNormal

For Each Picture In objWord.ActiveDocument.Shapes
i = i + 1
If "Rectangle 4" = Picture.Name Then

'MsgBox Picture.Name
objWord.ActiveDocument.Shapes(i).Select
'MsgBox objWord.ActiveDocument.Shapes(3).AlternativeText
Deg = Replace(WorksheetFunction.Trim(objWord.ActiveDocument.Shapes(3).AlternativeText), Chr(13), "")
ThisWorkbook.Sheets(ActiveSheet.Name).Cells(1, 1).Value = Deg

End If
Next Picture

docWord.Close False
objWord.Quit

Set docWord = Nothing


MsgBox "işlem tamam"



End Sub
 

Ekli dosyalar

halit3' Alıntı:
Dosyada referanslarda
Kod: 
'Microsoft word 12.0 object library

bu olmalı ayrıca örnek word dosya veri alınacak dosyanın yanında olmalı

Kod: 
Sub deneme()
'referanslar
'Microsoft word 12.0 object library

Dim objWord As Word.Application
Dim docWord As Word.Document
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
yol = ActiveWorkbook.Path & "\[COLOR="Red"]ÖRNEK CEVAP YAZISI.doc[/COLOR]"
Set docWord = objWord.Documents.Open(Filename:=yol, ReadOnly:=True)
Application.WindowState = wdWindowStateMinimize
'Application.WindowState = wdWindowStateNormal

For Each Picture In objWord.ActiveDocument.Shapes
i = i + 1
If "Rectangle 4" = Picture.Name Then

'MsgBox Picture.Name
objWord.ActiveDocument.Shapes(i).Select
'MsgBox objWord.ActiveDocument.Shapes(3).AlternativeText
Deg = Replace(WorksheetFunction.Trim(objWord.ActiveDocument.Shapes(3).AlternativeText), Chr(13), "")
ThisWorkbook.Sheets(ActiveSheet.Name).Cells(1, 1).Value = Deg

End If
Next Picture

docWord.Close False
objWord.Quit

Set docWord = Nothing


MsgBox "işlem tamam"



End Sub
Genişletmek için tıkla ...

Üstadım,

ilginden dolayı çok teşekkür ederim. Tek tek cevap yazılarının dosya yolunu belirtmek yerine, bir klasör belirtip, o klasör içerisinde yer alan tüm .doc'larda işlem yapmasını sağlayabilirmiyiz? Değerli yardım ve yönlendirmelerinizi rica ederim.

Saygılarımla, iyi çalışmalar.
 
Veya bu kodu deneyiniz.

Kod: 
Sub deneme7()
'referanslar
'Microsoft word 12.0 object library
'bilinmeyen nesneden veri al

Dim objWord As Word.Application
Dim docWord As Word.Document
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
yol = ActiveWorkbook.Path & "\ÖRNEK CEVAP YAZISI.doc"
Set docWord = objWord.Documents.Open(Filename:=yol, ReadOnly:=True)

For k = 1 To 50
Deg = Replace(Replace(WorksheetFunction.Trim(objWord.ActiveDocument.Shapes(k).AlternativeText), Chr(13), ""), Chr(9), "")
Deg = Mid(Deg, 15, Len(Deg))

If Mid(Deg, 1, 3) = "Sn." Then
i = i + 1
ThisWorkbook.Sheets(ActiveSheet.Name).Cells(i, 1).Value = Deg
deg1 = Split(Deg, Chr(10))
If UBound(deg1) > 0 Then
For j = 0 To UBound(deg1)
If deg1(j) <> "" Then
i = i + 1
Cells(i, 1).Value = deg1(j)
End If
Next j
End If
Exit For
End If
Next k

docWord.Close False
objWord.Quit

Set docWord = Nothing


MsgBox "işlem tamam"



End Sub
 
Herhalde aynı anda mesaj attık
Örnek olması için bir kaç tane word dosyası ekleyin bir bakalım
 
halit3' Alıntı:
Herhalde aynı anda mesaj attık
Örnek olması için bir kaç tane word dosyası ekleyin bir bakalım
Genişletmek için tıkla ...

Doğrudur üstadım,

Aynı anda mesajları iletmişiz :) Mesajım ekinde örnek toplu cevap yazıları yer almaktadır. Değerli yardım ve yönlendirmelerinizi rica ederim.

Teşekkürler & İyi çalışmalar.
 

Ekli dosyalar

kod:

Kod: 
Sub verial()

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
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Columns("A:Z").ClearContents
Range("A2:Z5000").ClearContents

Liste2 (Kaynak)

Cells.WrapText = False

Range("A1").Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
    
End Sub
 
Private Sub Liste2(Yol As String)
Dim fL As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")

For Each dosya In fL.GetFolder(Yol).Files

uzanti = LCase(fL.GetExtensionName(dosya.Name))
dosya_adi = fL.GetBaseName(dosya)

If uzanti = "doc" Or uzanti = "docx" Then

Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Set wrdApp = CreateObject("Word.Application")
wrdApp.Documents.Open (dosya)
wrdApp.Visible = True

t = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A2:A" & Rows.Count)) + 2

ThisWorkbook.Sheets(ActiveSheet.Name).Cells(t, 1) = Yol & ekle & dosya.Name
ThisWorkbook.Sheets(ActiveSheet.Name).Cells(t, 2) = dosya.Name

sut = 3

For k = 1 To 50
Deg = Replace(Replace(WorksheetFunction.Trim(wrdApp.ActiveDocument.Shapes(k).AlternativeText), Chr(13), ""), Chr(9), "")
Deg = Mid(Deg, 15, Len(Deg))

If Mid(Deg, 1, 3) = "Sn." Then

ThisWorkbook.Sheets(ActiveSheet.Name).Cells(t, sut).Value = Deg
deg1 = Split(Deg, Chr(10))
If UBound(deg1) > 0 Then
For j = 0 To UBound(deg1)
If deg1(j) <> "" Then
sut = sut + 1
ThisWorkbook.Sheets(ActiveSheet.Name).Cells(t, sut).Value = deg1(j)

ThisWorkbook.Sheets(ActiveSheet.Name).Cells(t, sut).WrapText = False

End If
Next j
End If
Exit For
End If
Next k

wrdApp.Documents.Close False
wrdApp.Quit

End If
atla:

Next

Set wrdApp = Nothing

On Error GoTo sonraki
For Each f In fL.GetFolder(Yol).SubFolders
Liste2 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub
 

Ekli dosyalar

halit3' Alıntı:
kod:

Kod: 
Sub verial()

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
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Columns("A:Z").ClearContents
Range("A2:Z5000").ClearContents

Liste2 (Kaynak)

Cells.WrapText = False

Range("A1").Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
    
End Sub
 
Private Sub Liste2(Yol As String)
Dim fL As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")

For Each dosya In fL.GetFolder(Yol).Files

uzanti = LCase(fL.GetExtensionName(dosya.Name))
dosya_adi = fL.GetBaseName(dosya)

If uzanti = "doc" Or uzanti = "docx" Then

Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Set wrdApp = CreateObject("Word.Application")
wrdApp.Documents.Open (dosya)
wrdApp.Visible = True

t = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A2:A" & Rows.Count)) + 2

ThisWorkbook.Sheets(ActiveSheet.Name).Cells(t, 1) = Yol & ekle & dosya.Name
ThisWorkbook.Sheets(ActiveSheet.Name).Cells(t, 2) = dosya.Name

sut = 3

For k = 1 To 50
Deg = Replace(Replace(WorksheetFunction.Trim(wrdApp.ActiveDocument.Shapes(k).AlternativeText), Chr(13), ""), Chr(9), "")
Deg = Mid(Deg, 15, Len(Deg))

If Mid(Deg, 1, 3) = "Sn." Then

ThisWorkbook.Sheets(ActiveSheet.Name).Cells(t, sut).Value = Deg
deg1 = Split(Deg, Chr(10))
If UBound(deg1) > 0 Then
For j = 0 To UBound(deg1)
If deg1(j) <> "" Then
sut = sut + 1
ThisWorkbook.Sheets(ActiveSheet.Name).Cells(t, sut).Value = deg1(j)

ThisWorkbook.Sheets(ActiveSheet.Name).Cells(t, sut).WrapText = False

End If
Next j
End If
Exit For
End If
Next k

wrdApp.Documents.Close False
wrdApp.Quit

End If
atla:

Next

Set wrdApp = Nothing

On Error GoTo sonraki
For Each f In fL.GetFolder(Yol).SubFolders
Liste2 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub
Genişletmek için tıkla ...

Üstadım ilgin için çok teşekkür ederim. 64 bit'te aşağıdaki hatayı alıyorum. Değrli bilgilerinizi rica ederim.

Deg = Replace(Replace(WorksheetFunction.Trim(wrdApp.ActiveDocument.Shapes(k).AlternativeText), Chr(13), ""), Chr(9), "")
Genişletmek için tıkla ...

Saygılarımla, iyi çalışmalar.
 
Ne diyeceğimi bilmiyorum kodun bu bölümünü

Kod: 
Set wrdApp = CreateObject("Word.Application")

bununla değiştirin

Kod: 
Set wrdApp = CreateObject("Word.Application.16")

kırmızı sayı değeriyle oynayın
12
13
14
15
16
gibi

ayrıca referanlar bölümünde word ün hangi sürümü mevcut

Kod: 
Microsoft word 12.0 object library
bunun gibi
 
halit3' Alıntı:
Ne diyeceğimi bilmiyorum kodun bu bölümünü

Kod: 
Set wrdApp = CreateObject("Word.Application")

bununla değiştirin

Kod: 
Set wrdApp = CreateObject("Word.Application.16")

kırmızı sayı değeriyle oynayın
12
13
14
15
16
gibi

ayrıca referanlar bölümünde word ün hangi sürümü mevcut

Kod: 
Microsoft word 12.0 object library
bunun gibi
Genişletmek için tıkla ...

Üstadım merhaba,

Değişiklikleri deniyorum, word sürümü ise;

Kod: 
Microsoft word 16.0 object library
[/QUOTE]

Saygılarımla, iyi çalışmalar dilerim.
 
referanlardan word ün sürümünü tikleyip işaretleyin
 
halit3' Alıntı:
Ne diyeceğimi bilmiyorum kodun bu bölümünü

Kod: 
Set wrdApp = CreateObject("Word.Application")

bununla değiştirin

Kod: 
Set wrdApp = CreateObject("Word.Application.16")

kırmızı sayı değeriyle oynayın
12
13
14
15
16
gibi

ayrıca referanlar bölümünde word ün hangi sürümü mevcut

Kod: 
Microsoft word 12.0 object library
bunun gibi
Genişletmek için tıkla ...



Üstadım,

Üzgünüm. Belirtmiş olduğunuz değişikliklerde de ilk önce verdiğim hatayı veriyor. Değerli yönlendirmelerinizi rica ederim.

Saygılarımla, iyi çalışmalar.
 
halit3' Alıntı:
referanlardan word ün sürümünü tikleyip işaretleyin
Genişletmek için tıkla ...

Üstadım,

Referansı en başta seçmiştim. Aslında ilk verdiğiniz kodlar çalıştı. Fakat klasör ile birçok dosyadan veri almak için hazırlanan kodlarda sıkıntı oluştu. Referans ile ilgili olduğunu düşünmüyorum. Başka bir fikriniz var mı? Değerli bilgilerinizi rica ederim.

Teşekkürler & iyi çalışmalar.
 
Son düzenleme:
f8 ile adım adım ilerle kontrol et eğer sarı renkli satır olursa onun resmini ekle
 
birde bu kodu dene

Kod: 
Dim say
Dim dosyalar(5000)
Dim dosyalar2(5000)
Sub mevcut_dosyaları_bul2()

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

say = 0
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Range("A2:Z5000").ClearContents

Liste1 (Kaynak)

For i = 1 To say
Dim objWord As Word.Application
Dim docWord As Word.Document
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Yol = dosyalar(i)
Set docWord = objWord.Documents.Open(Filename:=Yol, ReadOnly:=True)

sut = 3
t = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 2
ThisWorkbook.Sheets(ActiveSheet.Name).Cells(t, 1) = dosyalar(i)
ThisWorkbook.Sheets(ActiveSheet.Name).Cells(t, 2) = dosyalar2(i)

For k = 1 To 50
Deg = Replace(Replace(WorksheetFunction.Trim(objWord.ActiveDocument.Shapes(k).AlternativeText), Chr(13), ""), Chr(9), "")
Deg = Mid(Deg, 15, Len(Deg))

If Mid(Deg, 1, 3) = "Sn." Then

ThisWorkbook.Sheets(ActiveSheet.Name).Cells(t, sut).Value = Deg
deg1 = Split(Deg, Chr(10))
If UBound(deg1) > 0 Then
For j = 0 To UBound(deg1)
If deg1(j) <> "" Then
sut = sut + 1
ThisWorkbook.Sheets(ActiveSheet.Name).Cells(t, sut).Value = deg1(j)
End If
Next j
End If
Exit For
End If
Next k

docWord.Close False
objWord.Quit

Set docWord = Nothing
Next i


Cells.WrapText = False

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
Private Sub Liste1(Yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")

For Each dosya In fL.GetFolder(Yol).Files
uzanti = LCase(fL.GetExtensionName(dosya.Name))
dosya_adi = fL.GetBaseName(dosya)
If uzanti = "doc" Or uzanti = "docx" Then
say = say + 1
dosyalar(say) = dosya
dosyalar2(say) = dosya.Name
End If
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(Yol).SubFolders
Liste1 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub
 
halit3' Alıntı:
birde bu kodu dene

Kod: 
Dim say
Dim dosyalar(5000)
Dim dosyalar2(5000)
Sub mevcut_dosyaları_bul2()

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

say = 0
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Range("A2:Z5000").ClearContents

Liste1 (Kaynak)

For i = 1 To say
Dim objWord As Word.Application
Dim docWord As Word.Document
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Yol = dosyalar(i)
Set docWord = objWord.Documents.Open(Filename:=Yol, ReadOnly:=True)

sut = 3
t = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 2
ThisWorkbook.Sheets(ActiveSheet.Name).Cells(t, 1) = dosyalar(i)
ThisWorkbook.Sheets(ActiveSheet.Name).Cells(t, 2) = dosyalar2(i)

For k = 1 To 50
Deg = Replace(Replace(WorksheetFunction.Trim(objWord.ActiveDocument.Shapes(k).AlternativeText), Chr(13), ""), Chr(9), "")
Deg = Mid(Deg, 15, Len(Deg))

If Mid(Deg, 1, 3) = "Sn." Then

ThisWorkbook.Sheets(ActiveSheet.Name).Cells(t, sut).Value = Deg
deg1 = Split(Deg, Chr(10))
If UBound(deg1) > 0 Then
For j = 0 To UBound(deg1)
If deg1(j) <> "" Then
sut = sut + 1
ThisWorkbook.Sheets(ActiveSheet.Name).Cells(t, sut).Value = deg1(j)
End If
Next j
End If
Exit For
End If
Next k

docWord.Close False
objWord.Quit

Set docWord = Nothing
Next i


Cells.WrapText = False

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
Private Sub Liste1(Yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")

For Each dosya In fL.GetFolder(Yol).Files
uzanti = LCase(fL.GetExtensionName(dosya.Name))
dosya_adi = fL.GetBaseName(dosya)
If uzanti = "doc" Or uzanti = "docx" Then
say = say + 1
dosyalar(say) = dosya
dosyalar2(say) = dosya.Name
End If
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(Yol).SubFolders
Liste1 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub
Genişletmek için tıkla ...

Üstadım,

Yeni gönderdiğiniz kodda da hatayı aynı yerde alıyorum. Hatanın ekran görüntüsü mesajım ekinde tarafınıza takdim edilmiştir.

Saygılarımla, iyi çalışmalar dilerim.
 

Ekli dosyalar

birde bunu dene başkada olmazsa ofis 2016 yı yeniden yükle veya kaldır ofisin başka sürümünü yükle kodlar bende çalışıyor.

Kod: 
Dim say
Dim dosyalar(5000)
Dim dosyalar2(5000)
Sub mevcut_dosyaları_bul3()

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

say = 0
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Range("A2:Z5000").ClearContents

Liste1 (Kaynak)

For i = 1 To say
Dim objWord As Word.Application
Dim docWord As Word.Document
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Yol = dosyalar(i)
Set docWord = objWord.Documents.Open(Filename:=Yol, ReadOnly:=True)

sut = 3
t = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 2
ThisWorkbook.Sheets(ActiveSheet.Name).Cells(t, 1) = dosyalar(i)
ThisWorkbook.Sheets(ActiveSheet.Name).Cells(t, 2) = dosyalar2(i)

Dim Picture As Object

For Each Picture In objWord.ActiveDocument.Shapes
'If "Rectangle 4" = Picture.Name Then

Deg = Replace(Replace(WorksheetFunction.Trim(objWord.ActiveDocument.Shapes(Picture.Name).AlternativeText), Chr(13), ""), Chr(9), "")
Deg = Mid(Deg, 15, Len(Deg))

If Mid(Deg, 1, 3) = "Sn." Then

ThisWorkbook.Sheets(ActiveSheet.Name).Cells(t, sut).Value = Deg
deg1 = Split(Deg, Chr(10))
If UBound(deg1) > 0 Then
For j = 0 To UBound(deg1)
If deg1(j) <> "" Then
sut = sut + 1
ThisWorkbook.Sheets(ActiveSheet.Name).Cells(t, sut).Value = deg1(j)
End If
Next j
End If

Exit For
End If
'End If
Next Picture

docWord.Close False
objWord.Quit

Set docWord = Nothing
Next i


Cells.WrapText = False

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
Private Sub Liste1(Yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")

For Each dosya In fL.GetFolder(Yol).Files
uzanti = LCase(fL.GetExtensionName(dosya.Name))
dosya_adi = fL.GetBaseName(dosya)
If uzanti = "doc" Or uzanti = "docx" Then
say = say + 1
dosyalar(say) = dosya
dosyalar2(say) = dosya.Name
End If
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(Yol).SubFolders
Liste1 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub
 
halit3' Alıntı:
birde bunu dene başkada olmazsa ofis 2016 yı yeniden yükle veya kaldır ofisin başka sürümünü yükle kodlar bende çalışıyor.

Kod: 
Dim say
Dim dosyalar(5000)
Dim dosyalar2(5000)
Sub mevcut_dosyaları_bul3()

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

say = 0
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Range("A2:Z5000").ClearContents

Liste1 (Kaynak)

For i = 1 To say
Dim objWord As Word.Application
Dim docWord As Word.Document
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Yol = dosyalar(i)
Set docWord = objWord.Documents.Open(Filename:=Yol, ReadOnly:=True)

sut = 3
t = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 2
ThisWorkbook.Sheets(ActiveSheet.Name).Cells(t, 1) = dosyalar(i)
ThisWorkbook.Sheets(ActiveSheet.Name).Cells(t, 2) = dosyalar2(i)

Dim Picture As Object

For Each Picture In objWord.ActiveDocument.Shapes
'If "Rectangle 4" = Picture.Name Then

Deg = Replace(Replace(WorksheetFunction.Trim(objWord.ActiveDocument.Shapes(Picture.Name).AlternativeText), Chr(13), ""), Chr(9), "")
Deg = Mid(Deg, 15, Len(Deg))

If Mid(Deg, 1, 3) = "Sn." Then

ThisWorkbook.Sheets(ActiveSheet.Name).Cells(t, sut).Value = Deg
deg1 = Split(Deg, Chr(10))
If UBound(deg1) > 0 Then
For j = 0 To UBound(deg1)
If deg1(j) <> "" Then
sut = sut + 1
ThisWorkbook.Sheets(ActiveSheet.Name).Cells(t, sut).Value = deg1(j)
End If
Next j
End If

Exit For
End If
'End If
Next Picture

docWord.Close False
objWord.Quit

Set docWord = Nothing
Next i


Cells.WrapText = False

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
Private Sub Liste1(Yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")

For Each dosya In fL.GetFolder(Yol).Files
uzanti = LCase(fL.GetExtensionName(dosya.Name))
dosya_adi = fL.GetBaseName(dosya)
If uzanti = "doc" Or uzanti = "docx" Then
say = say + 1
dosyalar(say) = dosya
dosyalar2(say) = dosya.Name
End If
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(Yol).SubFolders
Liste1 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub
Genişletmek için tıkla ...

Merhaba,

Şimdi de hatasız bir şekilde çalıştı fakat sadece dosya yolu ve dosya adını aldı. Ayrıca birçok farklı bilgisayarda ve farklı sürümlerde denedim yine çalışmadı.

Teşekkürler & İyi çalışmalar.
 

Ekli dosyalar

Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst