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

ridvanucok · 7 Temmuz 2017

38 nolu mesajdaki ikinci kodu bununla değiştirin

Kod:

Sub deneme7()

Dim objWord As Word.Application
Dim docWord As Word.Document

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

[COLOR="red"]Say1 = 10[/COLOR]

For r = 2 To Cells(Rows.Count, "a").End(3).Row
Yol = Cells(r, 1).Value 'ActiveWorkbook.Path & "\ÖRNEK CEVAP YAZISI.doc"

Set objWord = CreateObject("Word.Application")
objWord.Visible = True

Set docWord = objWord.Documents.Open(Filename:=Yol, ReadOnly:=True)

sut = 3

ThisWorkbook.Sheets(ActiveSheet.Name).Cells(r, 2) = fL.GetFileName(Yol)

Dim Picture As Object

For Each Picture In objWord.ActiveDocument.Shapes

[COLOR="Red"]ThisWorkbook.Sheets(ActiveSheet.Name).Cells(Say1, 1).Value = Picture.Name

ThisWorkbook.Sheets(ActiveSheet.Name).Cells(Say1, 2).Value = Replace(Replace(WorksheetFunction.Trim(objWord.ActiveDocument.Shapes(Picture.Name).AlternativeText), Chr(13), ""), Chr(9), "")

Say1 = Say1 + 1[/COLOR]
'If "Rectangle 4" = Picture.Name Then
If "Rectangle" = Mid(Picture.Name, 1, 9) Then

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


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

ThisWorkbook.Sheets(ActiveSheet.Name).Cells(r, 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(r, sut).Value = deg1(j)
End If
Next j
End If

Exit For
End If
End If
Next

docWord.Close False
objWord.Quit

Set docWord = Nothing
Next r
Cells.WrapText = False
MsgBox "işlem tamam"



End Sub

birinci kodu çalıştırdıktan sonra bu kodu çalıştır ve dosyayı kayıt yap kayıt yapılan dosyayı buraya ekle
koda kırmızı yerleri ekledim ne gibi bir işlem yapıyor görmek isterim.

keşke TeamViewer ile uzaktan bağlanabilsek iyi olurdu

Üstadım,

Öncelikle banka güvenlik sistemleri dolayısı ile ne yazık ki uzaktan bağlantı sağlayamamaktayız. Fakat akşam müsait olursanız 19:00'da kişisel bilgisayarımda bu işlemi yapabiliriz. Bu arada belirtmiş olduğunuz değişiklikleri yaptım, çıktısını yazım ekinde tarafınıza takdim ediyorum.

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

halit3 · 7 Temmuz 2017

kod verileri alıyor ancak versiyon farkından bunu parçalamada sıkıntı oluyor

Kod:

Deg = Mid(Deg, 15, Len(Deg))

kodun yukarıdaki bölümünü bul

Kod:

Deg = Mid(Deg, [COLOR="Red"]10[/COLOR], Len(Deg))

kırmızı yer ile değiştir bakalım ne olacak

halit3 · 7 Temmuz 2017

bendeki dosyada ki nesneler böyle çıkıyor

Metin Kutusu:

sizdekinde ise

Text Box:

bu çıkıyor

ridvanucok · 7 Temmuz 2017

halit3' Alıntı:
bendeki dosyada ki nesneler böyle çıkıyor

Metin Kutusu:

sizdekinde ise

Text Box:

bu çıkıyor

Parçalamada hata alıyoruz. Peki rectangle 4'ü sadece göstermesini sağlayabilir miyiz? İhtiyacım olan o. Rectangle 4'ü aldıktan sonra parçalamayı halledebileceğimi düşünüyorum.

halit3 · 7 Temmuz 2017

Evet şimdi bu kodu bir dene

Kod:

Sub deneme7()

Dim objWord As Word.Application
Dim docWord As Word.Document

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

Say1 = 10
[COLOR="Red"]Aranan1 = "Metin Kutusu: "
Aranan2 = "Text Box: "[/COLOR]

For r = 2 To Cells(Rows.Count, "a").End(3).Row
Yol = Cells(r, 1).Value 'ActiveWorkbook.Path & "\ÖRNEK CEVAP YAZISI.doc"
Set objWord = CreateObject("Word.Application")
objWord.Visible = True

Set docWord = objWord.Documents.Open(Filename:=Yol, ReadOnly:=True)
sut = 3
ThisWorkbook.Sheets(ActiveSheet.Name).Cells(r, 2) = fL.GetFileName(Yol)

Dim Picture As Object

For Each Picture In objWord.ActiveDocument.Shapes
ThisWorkbook.Sheets(ActiveSheet.Name).Cells(Say1, 1).Value = Picture.Name
ThisWorkbook.Sheets(ActiveSheet.Name).Cells(Say1, 2).Value = Replace(Replace(WorksheetFunction.Trim(objWord.ActiveDocument.Shapes(Picture.Name).AlternativeText), Chr(13), ""), Chr(9), "")

Say1 = Say1 + 1
'If "Rectangle 4" = Picture.Name Then
If "Rectangle" = Mid(Picture.Name, 1, 9) Then
Deg = Replace(Replace(WorksheetFunction.Trim(objWord.ActiveDocument.Shapes(Picture.Name).AlternativeText), Chr(13), ""), Chr(9), "")

deg2 = Split(Deg, Aranan1)
If UBound(deg2) > 0 Then
Deg = deg2(1)
MsgBox Deg
End If

deg3 = Split(Deg, Aranan2)
If UBound(deg3) > 0 Then
Deg = deg3(1)
End If

'Deg = Mid(Deg, 15, Len(Deg))
If Mid(Deg, 1, 3) = "Sn." Then
ThisWorkbook.Sheets(ActiveSheet.Name).Cells(r, 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(r, sut).Value = deg1(j)
End If
Next j
End If

Exit For
End If
End If
Next

docWord.Close False
objWord.Quit

Set docWord = Nothing
Next r
Cells.WrapText = False
MsgBox "işlem tamam"



End Sub

ridvanucok · 7 Temmuz 2017

halit3' Alıntı:

Evet şimdi bu kodu bir dene

Kod:

Sub deneme7()

Dim objWord As Word.Application
Dim docWord As Word.Document

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

Say1 = 10
[COLOR="Red"]Aranan1 = "Metin Kutusu: "
Aranan2 = "Text Box: "[/COLOR]

For r = 2 To Cells(Rows.Count, "a").End(3).Row
Yol = Cells(r, 1).Value 'ActiveWorkbook.Path & "\ÖRNEK CEVAP YAZISI.doc"
Set objWord = CreateObject("Word.Application")
objWord.Visible = True

Set docWord = objWord.Documents.Open(Filename:=Yol, ReadOnly:=True)
sut = 3
ThisWorkbook.Sheets(ActiveSheet.Name).Cells(r, 2) = fL.GetFileName(Yol)

Dim Picture As Object

For Each Picture In objWord.ActiveDocument.Shapes
ThisWorkbook.Sheets(ActiveSheet.Name).Cells(Say1, 1).Value = Picture.Name
ThisWorkbook.Sheets(ActiveSheet.Name).Cells(Say1, 2).Value = Replace(Replace(WorksheetFunction.Trim(objWord.ActiveDocument.Shapes(Picture.Name).AlternativeText), Chr(13), ""), Chr(9), "")

Say1 = Say1 + 1
'If "Rectangle 4" = Picture.Name Then
If "Rectangle" = Mid(Picture.Name, 1, 9) Then
Deg = Replace(Replace(WorksheetFunction.Trim(objWord.ActiveDocument.Shapes(Picture.Name).AlternativeText), Chr(13), ""), Chr(9), "")

deg2 = Split(Deg, Aranan1)
If UBound(deg2) > 0 Then
Deg = deg2(1)
MsgBox Deg
End If

deg3 = Split(Deg, Aranan2)
If UBound(deg3) > 0 Then
Deg = deg3(1)
End If

'Deg = Mid(Deg, 15, Len(Deg))
If Mid(Deg, 1, 3) = "Sn." Then
ThisWorkbook.Sheets(ActiveSheet.Name).Cells(r, 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(r, sut).Value = deg1(j)
End If
Next j
End If

Exit For
End If
End If
Next

docWord.Close False
objWord.Quit

Set docWord = Nothing
Next r
Cells.WrapText = False
MsgBox "işlem tamam"



End Sub

Üstadım,

Harikasın. Kod çok güzel çalıştı. Herşey için çok teşekkür ederim.

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

halit3 · 7 Temmuz 2017

kodun son hali bu olmalı bunu ayrı bir dosya oluştur kodları orada çalıştır.

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)

Aranan1 = "Metin Kutusu: "
Aranan2 = "Text Box: "



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("A2: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
If "Rectangle" = Mid(Picture.Name, 1, 9) Then

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

deg2 = Split(Deg, Aranan1)
If UBound(deg2) > 0 Then
Deg = deg2(1)
End If

deg3 = Split(Deg, Aranan2)
If UBound(deg3) > 0 Then
Deg = deg3(1)
End If


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 · 7 Temmuz 2017

Buradan şunuda öğrendik ofis 2016 daki nesneler ile ofisin alt sürümündeki nesne farklarından dolayı bir türlü veri alınamıyordu taki en son çare mesajları sayfaya yazdırdıktan sonra görebildik.

ridvanucok · 7 Temmuz 2017

halit3' Alıntı:
Buradan şunuda öğrendik ofis 2016 daki nesneler ile ofisin alt sürümündeki nesne farklarından dolayı bir türlü veri alınamıyordu taki en son çare mesajları sayfaya yazdırdıktan sonra görebildik.

Üstadım,

Sorgular mükemmel çalışıyor. Desteğin, ilgin ve alakandan dolayı çok teşekkür ederim. Belirtmiş olduğun gibi her sorun yeni bir bilgi

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

halit3 · 7 Temmuz 2017

Teşekkürler iyi çalışmalar

ridvanucok · 7 Temmuz 2017

halit3' Alıntı:
Teşekkürler iyi çalışmalar

Üstadım,

En dikkat ettiğim husustur fakat iş yoğunluğundan unutkanlığıma verin. Ek olarak bir talebim daha olacak müsaitseniz.

Metni ararken Sn. olanları aratıyoruz fakat bazen kurum isimleri olabiliyor. Yani sadece Erzurum 24. İş Mahkemesi, Erzincan 12. İcra Dairesi, İstanbul Emniyet müdürlüğü v.s bunun için yapabileceğimiz bir işlem var mıdır? Kurumların başına sn. yazamayız çünkü kurumlara iletiyoruz.

Değerli yardımlarınızı rica ederim.

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

halit3 · 7 Temmuz 2017

Bunlarla ilgili örnek bir kaç tane örnek dosya ekleyin bir bakalım

ridvanucok · 7 Temmuz 2017

Üstadım,

Sorunun mantığını çözdüm. Şimdi kodlarda Sn. ile başlayan metin kutusunu al dediğimiz yere bir de T.C. ile başlayan metin kutularını al dememiz gerekiyor. Yani Sn. olanları kontrol et Sn. yoksa T.C. olanları kontrol et ve yazdır dememiz gerekiyor. Banka olarak kişi ve kurumlara cevap hazırlıyoruz. Sn. ile kişileri T.C. ile kurumları ayırt edebiliriz. Yanlız Sn. içeren metinlerin içinde de T.C. ibaresi de yer alıyor. Bunu da engellememiz lazım. Değerli yardım ve yönlendirmelerinizi rica ederim.

ridvanucok · 7 Temmuz 2017

Üstadım ayrıca şöyle bir geçici çözüm buldum. Wordden belgeleri almak için seçtiğimiz klasör sayısını 2'ye ayırdım. Birinde kişi'lere Sn. ile başlayan cevap yazıları, birinde de T.C. ile başlayan kurumlara ait cevap yazıları yer alıyor. Böylelikle her türlü çıktısını alabiliyorum

halit3 · 7 Temmuz 2017

O zaman sen sorunu çözmüşsün alternatif olarak (Rectangle 4) nesnesini arama olarak yapınca şöyle bir kod oluştu bunu bir dene hepsinde çalışması lazım.

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)

Aranan1 = "Metin Kutusu: "
Aranan2 = "Text Box: "



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("A2: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
'If "Rectangle" = Mid(Picture.Name, 1, 9) Then

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

deg2 = Split(Deg, Aranan1)
If UBound(deg2) > 0 Then
Deg = deg2(1)
End If

deg3 = Split(Deg, Aranan2)
If UBound(deg3) > 0 Then
Deg = deg3(1)
End If

'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

ridvanucok · 7 Temmuz 2017

halit3' Alıntı:

O zaman sen sorunu çözmüşsün alternatif olarak (Rectangle 4) nesnesini arama olarak yapınca şöyle bir kod oluştu bunu bir dene hepsinde çalışması lazım.

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)

Aranan1 = "Metin Kutusu: "
Aranan2 = "Text Box: "



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("A2: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
'If "Rectangle" = Mid(Picture.Name, 1, 9) Then

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

deg2 = Split(Deg, Aranan1)
If UBound(deg2) > 0 Then
Deg = deg2(1)
End If

deg3 = Split(Deg, Aranan2)
If UBound(deg3) > 0 Then
Deg = deg3(1)
End If

'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

Üstadım,

Mükemmel çalışıyor, eline emeğine sağlık.

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

halit3 · 7 Temmuz 2017

Şimdi fark ettim alınacak veri ("Rectangle 4") nesnesinde olmazsa ne olacak o zaman
kodu şöyle düzenlemek lazım.

kırmızı bölüme dikkat edin olay orada

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)

Aranan1 = "Metin Kutusu: "
Aranan2 = "Text Box: "



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("A2: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
If "Rectangle" = Mid(Picture.Name, 1, 9) Then

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

deg2 = Split(Deg, Aranan1)
If UBound(deg2) > 0 Then
Deg = deg2(1)
End If

deg3 = Split(Deg, Aranan2)
If UBound(deg3) > 0 Then
Deg = deg3(1)
End If

If [COLOR="Red"]Mid(Deg, 1, 3) = "Sn."[/COLOR] Or [COLOR="DarkOrange"]Mid(Deg, 1, 4) = "T.C."[/COLOR] 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 · 7 Temmuz 2017

yukarıdaki mesajdaki t.c. kodunu yeniden düzenledim

halit3 · 7 Temmuz 2017

BU kodda farklı değişkenleri kırmızı ile işaretledim

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)

Aranan1 = "Metin Kutusu: "
Aranan2 = "Text Box: "
[COLOR="Red"]bulunan1 = "Sn."
bulunan2 = "T.C."[/COLOR]



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("A2: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
If "Rectangle" = Mid(Picture.Name, 1, 9) Then

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

deg2 = Split(Deg, Aranan1)
If UBound(deg2) > 0 Then
Deg = deg2(1)
End If

deg3 = Split(Deg, Aranan2)
If UBound(deg3) > 0 Then
Deg = deg3(1)
End If

If Mid(Deg, 1, Len(bulunan1)) = bulunan1 Or Mid(Deg, 1, Len(bulunan2)) = bulunan3 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

ridvanucok · 7 Temmuz 2017

halit3' Alıntı:

BU kodda farklı değişkenleri kırmızı ile işaretledim

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)

Aranan1 = "Metin Kutusu: "
Aranan2 = "Text Box: "
[COLOR="Red"]bulunan1 = "Sn."
bulunan2 = "T.C."[/COLOR]



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("A2: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
If "Rectangle" = Mid(Picture.Name, 1, 9) Then

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

deg2 = Split(Deg, Aranan1)
If UBound(deg2) > 0 Then
Deg = deg2(1)
End If

deg3 = Split(Deg, Aranan2)
If UBound(deg3) > 0 Then
Deg = deg3(1)
End If

If Mid(Deg, 1, Len(bulunan1)) = bulunan1 Or Mid(Deg, 1, Len(bulunan2)) = bulunan3 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

Üstadım,

Bu kodda doğru çalışıyor. Fakat Sn. belirtecini kaldırdığınız kod daha çok işime yarayacaktır. Tekrar elinize emeğinize sağlık.

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

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

ridvanucok

Ekli dosyalar

halit3

Uzman

halit3

Uzman

Ekli dosyalar

ridvanucok

halit3

Uzman

ridvanucok

halit3

Uzman

halit3

Uzman

ridvanucok

halit3

Uzman

ridvanucok

halit3

Uzman

ridvanucok

ridvanucok

halit3

Uzman

ridvanucok

halit3

Uzman

halit3

Uzman

halit3

Uzman

ridvanucok