MsgBox Kodunda Uyarlama

[baysevimli]

Merhaba Arkadaşlar,

Aşağıdaki kodumun sonuçları MsgBox ile gösteriliyor. Sonuçların MsgBox yerine "C:\New folder\dosya" yolunda bulunan dosya isimli excelimin sütunlarına alt alta dökülmesi mümkünmüdür acaba ?

Sub aa()
ActiveDocument.Select
Metin = "Ankara - B.02.2.CHY.0.10.01.53#Antalya - B.02.2.CHY.0.18.03.54#Sivas - B.02.2.CHY.0.19.20.50#Mardin - B.02.2.CHY.0.09.01.52#İzmir - B.02.2.CHY.0.05.01.57"
Metin = Split(Metin, "#")
For i = 0 To UBound(Metin) - 1
MsgBox Metin(i) & " / " & UBound(Split(Selection, Metin(i))) & " Adet"
Next
End Sub

 

[asi_kral]

Merhaba
Bu şekilde dener misiniz ?
Dosya eklemediğiniz için deneme yapamadım.

Sub ab()
Dim KTP As Workbook, SYF As Worksheet
Dim YOL As String
Application.ScreenUpdating = False
ActiveDocument.Select
YOL = "C:\New folder\dosya\"
Set KTP = Workbooks.Open(YOL & "dosya.xlsx")
Set SYF = KTP.Sheets("Sayfa1")
Metin = "Ankara - B.02.2.CHY.0.10.01.53#Antalya - B.02.2.CHY.0.18.03.54#Sivas - B.02.2.CHY.0.19.20.50#Mardin - B.02.2.CHY.0.09.01.52#İzmir - B.02.2.CHY.0.05.01.57"
Metin = Split(Metin, "#")
For i = 0 To UBound(Metin) - 1
SYF.Range("A" & i + 1) = Metin(i) & " / " & UBound(Split(Selection, Metin(i))) & " Adet"
MsgBox Metin(i) & " / " & UBound(Split(Selection, Metin(i))) & " Adet"
Next
KTP.Save
KTP.Close
Application.ScreenUpdating = True
End Sub

 

[baysevimli]

Asi bey merhaba,

Maalesef çalışmadı.

Örnek dosyam ektedir.

 

[asi_kral]

Kodunuz örnek dosyada ekli değil ben eklemeye çalışıyorum kod hata veriyor.

 

[baysevimli]

Asi bey ekteki word dosyama sizin tavsiye ettiğiniz kodları ekleyerek tekrar upload ettim buyurun.

 

[asi_kral]

Siz benden kodu word dosyası için mi istediğiniz
Ben sadece sizin kodunuza gelen verileri excel sayfasına kaydetmesi için kod yazdım.
Kodun çalışır halini gönderir misiniz ?
Bakayım çözüm bulursam paylaşırım.
Word dosyası için ise istediğiniz konuyu burada açmanız gerekir

 

[baysevimli]

Asi bey merhaba

Kodu çalışır vaziyette word'e ekledim. Bu arada konuyu yanlış yerde açtığım için kusura bakmayın. Uğraştım ama Konuyu taşıyamadım.

 

[alicimri]

b.xlsx ve aşağıdaki kodun yazılı olduğu a.docx dosyalarını aynı klasörde imiş gibi ayarladım.

Sub aa()
ActiveDocument.Select
Metin = "Ankara - B.02.2.CHY.0.10.01.53#Antalya - B.02.2.CHY.0.18.03.54#Sivas - B.02.2.CHY.0.19.20.50#Mardin - B.02.2.CHY.0.09.01.52#İzmir - B.02.2.CHY.0.05.01.57"
Metin = Split(Metin, "#")
Set xl = CreateObject("excel.Application")
xl.workbooks.Open ActiveDocument.Path & "/b.xlsx"
For i = 0 To UBound(Metin) - 1
xl.Activeworkbook.Sheets("Sayfa1").Range("A" & i + 2).Value = Metin(i)

xl.Activeworkbook.Sheets("Sayfa1").Range("B" & i + 2).Value = UBound(Split(Selection, Metin(i)))
Next
xl.Activeworkbook.Save
xl.Application.Quit
Set xl = Nothing
End Sub

 

[baysevimli]

Ali bey ilginize tekrar teşekkür ederim. Yanlız bunda da istediğim sonucu alamadım. Aslında sizin daha önce ilgilendiğiniz http://www.excel.web.tr/f48/word-dosyasynda-aradyoym-kriterleri-saydyrmak-t159610/sayfa3.html konuya bakabilir misiniz. Bir eksiğim kaldı onda. Onu yapabilirsek istediğimi tam olarak halletmiş olucam.