• 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

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

Üstadım merhaba,

Bankamızın cevap yazılarında bir değişikliğe gidildi ve sabit olan rectangle 4 cevap yazılarımızda farklılık gösterebiliyor. Bunu rectangle 4 olarak sabitlemek yerine T.C., Sn. v.s belirleyeceğimiz kriterler doğrultusunda çalışabilmesi için entegre edebilir miyim?

Değerli bilgilerinizi rica ederim.
 
ridvanucok' Alıntı:
Üstadım merhaba,

Bankamızın cevap yazılarında bir değişikliğe gidildi ve sabit olan rectangle 4 cevap yazılarımızda farklılık gösterebiliyor. Bunu rectangle 4 olarak sabitlemek yerine T.C., Sn. v.s belirleyeceğimiz kriterler doğrultusunda çalışabilmesi için entegre edebilir miyim?

Değerli bilgilerinizi rica ederim.
Genişletmek için tıkla ...

bu kod saten onu yapıyor söylediğiniz bölüm aktif değil

Kod: 
'If "Rectangle 4" = Picture.Name Then

Dediğiniz bölüm burası oda aktif değil zaten

58 ve 59 nolu mesajdaki kodlar işinizi görmesi lazım
 
halit3' Alıntı:
bu kod saten onu yapıyor söylediğiniz bölüm aktif değil

Kod: 
'If "Rectangle 4" = Picture.Name Then

Dediğiniz bölüm burası oda aktif değil zaten

58 ve 59 nolu mesajdaki kodlar işinizi görmesi lazım
Genişletmek için tıkla ...

Üstadım,

Mesajı yazmadan önce tüm kodları denedim, kendimce düzenlemeye de çalıştım ama 59. mesajınızdaki kodlarda boş döküyor yine makro. Daha önce olduğu gibi sadece dossya yolu ve dosya adını döküyor.

Saygılarımla,
 
önce yeni oluşturulan örnek dosyalardan bir kaç tane buraya ekle daha sonra 38 ve 40 nolu mesajdaki kodları çalıştır çıkan sonucu ait dosyayı da ekle bakalım
 
halit3' Alıntı:
önce yeni oluşturulan örnek dosyalardan bir kaç tane buraya ekle daha sonra 38 ve 40 nolu mesajdaki kodları çalıştır çıkan sonucu ait dosyayı da ekle bakalım
Genişletmek için tıkla ...

Üstadım,

Örnek cevap yazıları, 38 ve 40 mesajdaki kodlarla işlenmiş excel dosyası ekte tarafına takdim edilmiştir. Ek olarak .rtf formatına geçiş yaptık. Kodlarda uzantı olarak "rtf"'yi ekleyerek kodu çalıştırdım. Excel çıktısını da incelediğimde rectangle 4'ün dışında 2 ve 5'de de kurum bilgisi olduğunu gördüm.

Değerli bilgi ve yönlendirmelerini rica ederim.
 

Ekli dosyalar

kod:

Kod: 
Dim Say
Dim dosyalar(5000)
Dim dosyalar2(5000)
Sub mevcut_dosyaları_bul4()

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)

[COLOR="Red"]Aranan1 = "Metin Kutusu: "
Aranan2 = "Text Box: "
bulunan1 = "Sn."
bulunan2 = "TC."
bulunan3 = "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, [COLOR="red"]Aranan1[/COLOR])
If UBound(deg2) > 0 Then
Deg = deg2(1)
End If

deg3 = Split(Deg, [COLOR="red"]Aranan2[/COLOR])
If UBound(deg3) > 0 Then
Deg = deg3(1)
End If

[COLOR="red"]If Mid(Deg, 1, Len(bulunan1)) = bulunan1 Or Mid(Deg, 1, Len(bulunan2)) = bulunan2 Or Mid(Deg, 1, Len(bulunan3)) = bulunan3 Then[/COLOR]

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 = "rtf" Or 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ı:
kod:

Kod: 
Dim Say
Dim dosyalar(5000)
Dim dosyalar2(5000)
Sub mevcut_dosyaları_bul4()

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)

[COLOR="Red"]Aranan1 = "Metin Kutusu: "
Aranan2 = "Text Box: "
bulunan1 = "Sn."
bulunan2 = "TC."
bulunan3 = "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, [COLOR="red"]Aranan1[/COLOR])
If UBound(deg2) > 0 Then
Deg = deg2(1)
End If

deg3 = Split(Deg, [COLOR="red"]Aranan2[/COLOR])
If UBound(deg3) > 0 Then
Deg = deg3(1)
End If

[COLOR="red"]If Mid(Deg, 1, Len(bulunan1)) = bulunan1 Or Mid(Deg, 1, Len(bulunan2)) = bulunan2 Or Mid(Deg, 1, Len(bulunan3)) = bulunan3 Then[/COLOR]

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 = "rtf" Or 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 merhaba,

İlginiz için tekrar teşekkür ederim. Kodlar istediğim şekilde çalışıyor. İyi çalışmalar dilerim.
 
teşekkürler iyi çalışmalar
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst