Wordden Kopyala Excele Yapıştır.

[askm]

Kolay gelsin. Excelde butona basınca word (doc, docx ) dosyasını seçtirip, Açılan word dosyasından CTRL + A ile tüm metni kopyalayıp excele Sayfa1!A1 hücresinden itibaren yapıştırmak istiyorum. VBA ile bunu yapma imkanı var mı?

 

[Ömer BARAN]

Merhaba.

Aşağıdaki gibi istediğiniz olur.
Sayfa1'e bir düğme/şekil/metin kutusu ekleyip,
bu düğme/şekil/metin kutusu ile aşağıdaki kod'u ilişkilendirin.
.

[FONT="Arial Narrow"][B]Sub WORDDEN_AL()[/B]
Dim wrd, doc As Object
With Application.FileDialog(msoFileDialogFilePicker)
     .AllowMultiSelect = False: .Filters.Add "Word Belgeleri", "*.doc, *.docx", 1
     If .Show = -1 Then
        Set wrd = CreateObject("Word.Application"): wrd.Application.Visible = True
        Set doc = wrd.documents.Open(.SelectedItems(1))
        With doc.ActiveWindow.Selection
            .WholeStory: .Copy: End With
     Else: Exit Sub: End If: End With
doc.Close 0
wrd.Quit: Set doc = Nothing: Set wrd = Nothing
ActiveSheet.[A1].Select: ActiveSheet.Paste: ActiveSheet.[A1].Select
[B]End Sub[/B][/FONT]

 

[askm]

İlginiz için çok teşekkür ederim.

 

[askm]

Almak istediğim belge biraz uzun. Şu anda kilitlendi. Hızlandırma imkanı olur mu. Ya da satır satır alma imkanı var mı.

 

[tahsinanarat]

Sn. leumruk beyin kodlarıdır

Sub Worde_Satir_Aktar()
Application.ScreenUpdating = False
Set WD = CreateObject("Word.Application")
dosya = ThisWorkbook.Path & "\1999-518.doc"
WD.Application.documents.Open dosya
WD.Visible = True
SonSat = WD.ActiveDocument.Range.ComputeStatistics(1)
Do
x = x + 1
WD.Selection.GoTo What:=3, Which:=1, Count:=x, Name:=""
Satir = WD.Selection.Bookmarks("\line").Range
Cells(x, 1) = Satir
Loop While x <> SonSat
WD.Application.Quit
MsgBox "Aktarım tamamlandı.", vbInformation, "l e u m r u k"
End Sub

Not. dosya adı kod içerisinde yazıyor, Sn. Ömer hocam dosyayı seçmeli olarak düzeltebilir, wordeki her satır, excele satır olarak alınmaktadır.

 

[askm]

Teşekkür ederim tahsinanarat. Ömer Beyin verdiği kod gibi yapıştırmıyor. O yuzden işime yaramadı. Sayfada sorular ve şıklar var. soruların ilk satırını alıyor. Devamını almıyor. Şıkları hiç almıyor.
Ömer Bey wordden alma kodunda word belgesinde "Kopyaladağınız son öğeyi saklamak istiyor musunuz? " diye uyarı veriyor. Bunu engelleme imkanı var mı. seçeceğim klasör içerisindeki dosyaları sırası ile her wordde yeni sayfa açacak şekilde alma imkanı olur mu? Yani word belgesini değilde klasörü seçtirsek. İçerisinde 10 tane word belgesi var mesela. Onları tek tek 1.sayfa 2. sayfa ekleyerek sayfalara yapıştırabilir miyiz.

 

[tahsinanarat]

Sn. askm Word dosyanızın orijinal bir kaç örneğini eklermisiniz, birde bu örneklerin excele ne şekilde alınacağının örneğini manuel olarak ekleyin ki afaki bir çalışma olmasın, sizin örnekler üzerinde çözüm üretilebilsin. Word dosyaları mevcut dosyalar mı yoksa onları günübirlik sizmi hazırlıyorsunuz.

 

[jeoferkan]

Sayın tahsinanarat konunun takıpcısı olmak adına alınan word dosyasını excele aktarırken sayfa dışına taşırmadan aktarsa ne güzel olur, aktardıktan sonra tek tek satırları düzenlemek zor oluyor. bu sorunuda aradan çıkarırsanız ne güzel olur, memnun olurum. Kolay gelsin

 

[tahsinanarat]

Sn. jeoferkan, excele aktarmış olduğunuz a sütununu hücre biçimlendir, hizalama, metni kaydır seçeneğine tik koyarsanız ve sutunuda sayfa görüntüsünü taşmayacak şekilde enini ayarlarsanız taşmaz.

 

[assenucler]

Teşekkürler

Sayın Ömer BARAN,


Üstadım iyi akşamlar.

Yazdığınız kodu kullandım. Benim de çok işime yarayacak, çok teşekkürler.

Selam ve sevgiler.

 

[Ömer BARAN]

Sayın Ömer BARAN,


Üstadım iyi akşamlar.

Yazdığınız kodu kullandım. Benim de çok işime yarayacak, çok teşekkürler.

Selam ve sevgiler.

Estağfurullah, işinize yaradığına sevindim Sayın ŞENÜÇLER.
Sağlıcakla.
.

 

[askm]

Sayın Tahsinanarat örnek dosya ekte sunuyorum. Yapmak istediğim asıl işlem, sorular B sütununda şıklar sırası ile C D E ve F sütunlarına gelsin istiyorum. Sayfayı excele aldıktan sonra farklı kod çalıştırarak bu işlemi ikinci bir makro ile yapabilirim sanırım.

 

[tahsinanarat]

Dosyanız ekte

Bir kaç aşama ile istediğiniz şekle getirebildim, Word dosyalarının aynı formatta olmaları gerekiyor, örnekdeki dosyaları ben düzenledim, şöyleki;
-Tek sutun olacak, Word de iki veya fazla sutun olmamalı
-Sorular yazılırken enter ile alt satıra geçilmeden devam edilmeli.
-Cevap şıkları alt alta yazılmalı, yan yana olmamalı

Not: kodları çalıştırmadan önce Sayfa1 deki alanı tamamen temizleyiniz, yada kodların içine temizleme kodları ilave ediniz
Sub WORDDEN_AL() altına aşağıdaki kodları ilave ediniz.
Cells.Select
Selection.ClearContents
Range("A1").Select

 

[tahsinanarat]

Soruların b sütununda şıklar sırası ile C D E ve F kalması için aşağıdaki kodu değiştiriniz.

Sub WORDDEN_AL()
Cells.Select
Selection.ClearContents
Dim wrd, doc As Object
With Application.FileDialog(msoFileDialogFilePicker)
     .AllowMultiSelect = False: .Filters.Add "Word Belgeleri", "*.doc, *.docx", 1
     If .Show = -1 Then
        Set wrd = CreateObject("Word.Application"): wrd.Application.Visible = True
        Set doc = wrd.documents.Open(.SelectedItems(1))
        With doc.ActiveWindow.Selection
            .WholeStory: .Copy: End With
     Else: Exit Sub: End If: End With
doc.Close 0
wrd.Quit: Set doc = Nothing: Set wrd = Nothing
ActiveSheet.[A1].Select: ActiveSheet.Paste: ActiveSheet.[A1].Select
Birlestir
Ayir
Sartli_Sil
listele
    Columns("A:B").Select
    Selection.Delete Shift:=xlToLeft
    Columns("A:A").Select
    Selection.Rows.AutoFit
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A1").Select
    MsgBox "Gruplandırma yapıldı."
End Sub

 

[askm]

Kodlar için teşekkürler. Sabah bakarım inşallah. Yalnız Birlestir
Ayir
Sartli_Sil
listele
adında kod göremedim. Kodların bu kısmını biraz açıklayabilirseniz, müteşekkir olurum.

 

[tahsinanarat]

Bir önceki mesajında dosyanızı gonderdim

 

[askm]

İlginiz ve emeğiniz için çok teşekkür ederim. Allah razı olsun.