• 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

en son mesajımdaki kodları yeniden al ve dene ben kodları bir kaç dakika arasında değiştirmiştim.
 
halit3' Alıntı:
en son mesajımdaki kodları yeniden al ve dene ben kodları bir kaç dakika arasında değiştirmiştim.
Genişletmek için tıkla ...

Üstadım,

Malesef farklı bilgisayar ve sürümlerde denememe rağmen sadece dosya adı ve dosya uzantısını getiriyor.

Teşekkürler, iyi çalışmalar.
 
kodlar bende çalışıyor görsel video ekliyorum

görsel video

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("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), "")
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

video dosyası yükleniyor yaklaşık 10 dakikası var
 

Ekli dosyalar

bilgisayarınızda kısıtlama varmı c sürücüsü yerine dosyaları farklı bir sürücüye kapyalayın ve dosyayı oradan çalıştırın
 
Üstadım,

Excel'de seçili olan referanslarınızın isimlerini tarafıma iletme şansınız var mı? Ondan kaynaklanıyor olabilir mi acaba? Çünkü bende yine ne yazık ki çalışmadı. Kusura bakmayın biraz geç cevap veriyorum. Çünki 5 farklı bilgisayarda farklı sürümlerde deniyorum.

Teşekkürler.
 
Bendeki referanslar böyle

Kod: 
Visual Basic For Applications
Microsoft Excel 11.0 Object Library
OLE Automation
Microsoft Word 12.0 Object Library
Microsoft Forms 2.0 Object Library

Bilgisayarınızda kısıtlama mevcut mu bu soruma cevap alamadım
 
Merhaba,

Evet, bilgisayarımda kısıt mevcut. Farklı sürücüye atarak yine çalıştırdım dosyaları ama sonuç alamadım.
 
kısıtlamalar mevcut olduğu sürece bu işlemleri biraz zor yapılır.
 
siz bu kodları harici bir bilgisayar varsa orada deneyin
 
halit3' Alıntı:
siz bu kodları harici bir bilgisayar varsa orada deneyin
Genişletmek için tıkla ...

Üstadım,

Herşey için çok teşekkür ederim. Şuan şirketteyim, eve geçince bir de evde deneyeyim o halde. Admin kullanıcıdan da çalıştırdığımda yine hata aldım. Bi bakalım evdeki bilgisayarımda da aynı hata devam edecek mi.

İyi çalışmalar dilerim.
 
ridvanucok' Alıntı:
Üstadım,

Herşey için çok teşekkür ederim. Şuan şirketteyim, eve geçince bir de evde deneyeyim o halde. Admin kullanıcıdan da çalıştırdığımda yine hata aldım. Bi bakalım evdeki bilgisayarımda da aynı hata devam edecek mi.

İyi çalışmalar dilerim.
Genişletmek için tıkla ...

Sadece bir deneme , tüm dosyalarınızı C:\deneme klasörüne kopyalayıp orada dener misiniz?
 
asri' Alıntı:
Sadece bir deneme , tüm dosyalarınızı C:\deneme klasörüne kopyalayıp orada dener misiniz?
Genişletmek için tıkla ...

Asri üstadım merhaba,

Ne yazık ki C sürücüsünde deneme klasöründe çalıştırdığımda da sonuç aynı. Sadece dosya yolu ve dosya adını getiriyor. Diğer bilgileri almıyor. Teşekkürler.

halit3' Alıntı:
siz bu kodları harici bir bilgisayar varsa orada deneyin
Genişletmek için tıkla ...

Halit üstadım size de merhaba,

Ne yazık ki kişisel bilgisayarımda tüm yetkiler mevcut kullanıcı ile denediğimde yine sadece dosya yolu ve uzantısı bilgilerini alabildim. Teşekkürler.
 
ridvanucok' Alıntı:
Asri üstadım merhaba,

Ne yazık ki C sürücüsünde deneme klasöründe çalıştırdığımda da sonuç aynı. Sadece dosya yolu ve dosya adını getiriyor. Diğer bilgileri almıyor. Teşekkürler.



Halit üstadım size de merhaba,

Ne yazık ki kişisel bilgisayarımda tüm yetkiler mevcut kullanıcı ile denediğimde yine sadece dosya yolu ve uzantısı bilgilerini alabildim. Teşekkürler.
Genişletmek için tıkla ...

kişisel bilgisayarınızda ofisin hangi sürümü yüklü işletim sistemi ney
ayrıca ilk yazdığım mesajdaki kodlardan tek dosyadan veri alınabiliyormuydu
 
halit3' Alıntı:
kişisel bilgisayarınızda ofisin hangi sürümü yüklü işletim sistemi ney
ayrıca ilk yazdığım mesajdaki kodlardan tek dosyadan veri alınabiliyormuydu
Genişletmek için tıkla ...

Üstadım,

Windows 10 x64 işletim sistemi, office 2016 yüklü. İlk yazdığınız mesajdaki kodlardan tek dosyadan şirketten de evden de veri alabiliyorum.

halit3' Alıntı:
Excel güvenlik ayarlarınız böylemi

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

Excel makro güvenliği ayarlarım belirtmiş olduğunuz gibi.

Teşekkürler.
 
birde şöyle deneyelim
bu kodu çalıştır a sütununa dosya adresleri gelecektir.

Kod: 
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

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

Liste2 (Kaynak)

Set Klasor = Nothing

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, 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
Say1 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A2:A" & Rows.Count)) + 2
Cells(Say1, 1) = Dosya
End If
Next

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

Set fL = Nothing
End Sub

daha sonra bu kodu çalıştır
Kod: 
Sub deneme7()

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

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



For r = 2 To Cells(Rows.Count, "a").End(3).Row
Yol = Cells(r, 1).Value

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
'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))



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

ayrıca şunu söylüyüm sizin buraya eklemiş olduğunuz dosyalardan veri alıyorum ben gerçek dosyanız nasıl bilemem
 
halit3' Alıntı:
birde şöyle deneyelim
bu kodu çalıştır a sütununa dosya adresleri gelecektir.

Kod: 
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

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

Liste2 (Kaynak)

Set Klasor = Nothing

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, 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
Say1 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A2:A" & Rows.Count)) + 2
Cells(Say1, 1) = Dosya
End If
Next

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

Set fL = Nothing
End Sub

daha sonra bu kodu çalıştır
Kod: 
Sub deneme7()

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

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



For r = 2 To Cells(Rows.Count, "a").End(3).Row
Yol = Cells(r, 1).Value

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
'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))



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

ayrıca şunu söylüyüm sizin buraya eklemiş olduğunuz dosyalardan veri alıyorum ben gerçek dosyanız nasıl bilemem
Genişletmek için tıkla ...

Üstadım,

Kodları tek tek çalıştırdım fakat yine sonuç aynı. Sadece dosya yolu ve adını listeliyor. Gerçek dosyalarımız birebir aynı yapıya sahip.
 
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
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst