excelden worde metin ve tablo aktarma

[tensinor]

Merhaba arkadaşlar;
Kolay gelsin. Ekteki dosyada bulunan metni worde aktarmak istiyorum. Ancak:
1-A sutununda bulunan hücrelerden boş olan veya sıfır(0) olanlar worde atılırken gizlenmesi ve wordde gözükmesini istemiyorum.
2-Excelde metnin içinde yer alan tablonun worde sığmasını istiyorum(Metinler A-G sütunları arasında ancak tablo H sutununa kadar uzanıyor).
Yardımlarınız için şimdiden çok teşekkür ederim.

 

[mancubus]

şöyle bir şey olabilir.
kopyalanacak sayfanın kopyası üzerinden işlem yapılıp sonra bu kopya silinmektedir.
sayfada A stunundaki hücre 0 ise (boş veya değeri 0) satırı gizlenmekte, kalan her şey word'e kopyalanmaktadır.

Sub Excel_den_Word_e()
'VBE'de tools-references'dan Microsoft Word 14.0 Object Library işaretlenmelidir.
    
    Dim appWord As Word.Application
     
    Worksheets("deneme1").Copy After:=Worksheets(Worksheets.Count)
    With ActiveSheet
        sonsat = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
        For i = sonsat To 1 Step -1
            Rows(i).Hidden = .Cells(i, 1) = 0
        Next i
        .UsedRange.Copy
    End With
    
    Set appWord = New Word.Application
    appWord.Visible = True
    appWord.Documents.Add.Content.Paste
    
    With Application
        .DisplayAlerts = False
        ActiveSheet.Delete
        .DisplayAlerts = True
    End With
    
    Worksheets("deneme1").Activate
    
End Sub

 

[tensinor]

Çok teşekkür ederim.Emeğinize sağlık

 

[mancubus]

rica ederim.
işe yaradığına sevindim.

geri bildirim için de ben teşekkür ederim. bu özellik forumda azalmaya başladı gibi bir hisse kapılıyorum son zamanlarda.

 

[tensinor]

Kodlar gönderdiğim dosya üzerinde çalışıyor. Ancak çok sayıda sayfası olan excel kitabında(kitabın her sayfasının bir adı var,"giriş","çıkış" gibi) çalıştıramadım. Sanırım küçük bazı değişiklikler gerekiyor.Run time error 13- Type mismatch hatası veriyor.
Kod ekranını kapatıp excele geri döndüğümde "Deneme1" adlı sayfanın programı her çalıştırdığımda kopyalandığını gördüm(yani program çalıştığında bir word sayfası açıp verileri ona aktarmak yerine programın çalıştığı excel kitabı içinde yeni bir sayfaya aktarıyor.Bu yeni sayfalara "deneme1(2)","deneme1(3)"... gibi adlar veriyor.İlginiz için teşekkür ederim.

 

[mancubus]

şimdi 1. mesajınızı ve 5. mesajınızı tekrar okuyor ve aradaki 7 farkı bana söylüyorsunuz.

aslında, dosyanızın ve ihtiyacınızın ilk mesajda bahsettiğinizden farklı olduğunu söylüyorsunuz.

ihtiyaç farklı ise çözüm de farklı olacaktır.

yoksa ilk çözümüm tam olarak ilk ihtiyacınıza cevap vermektedir.

 

[mancubus]

aşağıdaki kod excel dosyasındaki tüm sayfaları, A sütunundaki değer 0 veya boş ise gizleyerek word dosyası yapmaktadır.

bonus olarak word dosyasını excel sayfa ismi ile aynı klasöre kaydeden kodları da ekledim.

Sub Excel_Sayfalarini_Word_Dokumani_Yap()
    
    Dim appWord As Word.Application
    Dim docWord As Word.Document
    Dim fPath As String, fName As String
    Dim i As Long, j As Long, calc As Long, LastRow As Long
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        calc = .Calculation
        .Calculation = xlCalculationManual
    End With
    
    fPath = ThisWorkbook.Path & "\"
    
    For i = 1 To ThisWorkbook.Worksheets.Count
        With Worksheets(i)
            fName = .Name
            LastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
            For j = LastRow To 1 Step -1
                .Rows(j).Hidden = .Cells(j, 1) = 0
            Next j
            .UsedRange.Copy
        End With
        Set appWord = New Word.Application
        With appWord
            .Visible = True
            Set docWord = .Documents.Add
            With docWord
                .Content.Paste
                .SaveAs fPath & fName & ".docx", FileFormat:=wdFormatDocumentDefault
                .Close
            End With
            .Quit
        End With
        Set wrdDoc = Nothing
        Set wrdApp = Nothing
        With Worksheets(i)
            LastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
            For j = LastRow To 1 Step -1
                If .Rows(j).Hidden = True Then .Rows(j).Hidden = False
            Next j
        End With
    Next i
    
    With Application
        .Calculation = calc
        .CutCopyMode = False
    End With

End Sub

 

[mancubus]

bütün sayfaları word yapmak arzusunda değilim. sadece istediğim sayfalar word olsun derseniz aşağıdaki kod da bunun için.

word'e aktarmak istediğiniz sayfayı seçerek kodu çalıştıracaksınız.

Sub Aktif_Olan_Excel_Sayfasini_Word_Dokumani_Yap()
    
    Dim appWord As Word.Application
    Dim docWord As Word.Document
    Dim fPath As String, fName As String
    Dim j As Long, calc As Long, LastRow As Long
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        calc = .Calculation
        .Calculation = xlCalculationManual
    End With
    
    fPath = ThisWorkbook.Path & "\"
    
    With ActiveSheet
        fName = .Name
        LastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
        For j = LastRow To 1 Step -1
            .Rows(j).Hidden = .Cells(j, 1) = 0
        Next j
        .UsedRange.Copy
    End With
    Set appWord = New Word.Application
    With appWord
        .Visible = True
        Set docWord = .Documents.Add
        With docWord
            .Content.Paste
            .SaveAs fPath & fName & ".docx", FileFormat:=wdFormatDocumentDefault
            .Close
        End With
        .Quit
    End With
    Set wrdDoc = Nothing
    Set wrdApp = Nothing
    With ActiveSheet
        LastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
        For j = LastRow To 1 Step -1
            If .Rows(j).Hidden = True Then .Rows(j).Hidden = False
        Next j
    End With
    
    With Application
        .Calculation = calc
        .CutCopyMode = False
    End With

End Sub

 

[tensinor]

Gönderdiğiniz kodlar istediğimden de iyi çok teşekkür ederim. Özellikle son gönderdiğiniz kodu denemeye çalıştım. Boş bir excel kitabında denedim. Word ikonu aşağıda gördüm ve yok oldu. Sonra o belgeyi wordun geçmişinden açtım. Tam da gerektiği gibi çalışmış.Ancak projemin olduğu excel dosyamda "Run time error 13: Type mismatch" hatası veriyor. Siz mesajı gönderdiğinizden beri uğraşıyorum çözemedim.( Bu arada visual basic ve makroları temel düzeyde bile bilmediğimi daha fazla geç olmadan söyleyeyim ) Ayrıca benim bilgisayarda microsoft word library 12.0 yüklü.Konuya hakim olamadığımdan inşallah gene eksik bilgi vermemişimdir. Çok teşekkürler

 

[mancubus]

ben test ederek koymuştum. problem yoktu.

dosyanızı temsili verilerle yüklerseniz bakalım.

word uygulamasını açık tutmak, kaydedilen dosyaları açık kapalı tutmak bizim elimizde.

with bloku içindeki .Close ifadesi dosyayı kapatıyor, dışarıdaki .Quit ise word uygulamasını.

ben çalıştığını görün diye word'u görünür yaptım. benim çalışmam olsa .Visible = True ifadesini .Visible = False yapar ve word'ü hiç görüntülemezdim.

 

[mancubus]

Gönderdiğiniz kodlar istediğimden de iyi çok teşekkür ederim. Özellikle son gönderdiğiniz kodu denemeye çalıştım. Boş bir excel kitabında denedim. Word ikonu aşağıda gördüm ve yok oldu. Sonra o belgeyi wordun geçmişinden açtım. Tam da gerektiği gibi çalışmış.Ancak projemin olduğu excel dosyamda "Run time error 13: Type mismatch" hatası veriyor. Siz mesajı gönderdiğinizden beri uğraşıyorum çözemedim.( Bu arada visual basic ve makroları temel düzeyde bile bilmediğimi daha fazla geç olmadan söyleyeyim ) Ayrıca benim bilgisayarda microsoft word library 12.0 yüklü.Konuya hakim olamadığımdan inşallah gene eksik bilgi vermemişimdir. Çok teşekkürler

kodun hangi satırında bu hatayı veriyor?

referanslardan 12.0'ı işaretleyeceksiniz. ve işaretlemişsiniz. yoksa hata verirdi.

wdFormatDocumentDefault hatalı olabilir diye düşündüm ama docx formatı versiyondan bağımsız bu. bu ifadenin yerine 16 da yazılabilir.

 

[tensinor]

Yardımınız için çok teşekkür ederim. Verdiğiniz kodları ancak kullanmaya başlayabildim. Zira öğrendikçe hataları mı gördüm. Kodlarınızın benim dosyamda çalışmama nedeni bazı durumlarda silinmesi gereken hücrelerin hata vermesiymiş.Bu durum düzelince kodlar gayet güzel çalıştı.
8. mesajda yer alan "Aktif olan Excel sayfasını word yapan" kodları kullanıyorum. Yalnız bazı sorunlarım var:

1- Metinler wordde Times New Roman 12 olarak yazılmasını istiyorum(bilgisayar calibri olarak ayarlı)

2- Worde aktardığında wordde hücre ile aktarıyor. Yani worde aktarılan metinlerde görünmeyen kenarlıklar var(her ne kadar worde aktarıldığında tam istediğim gibi klavuz çizgileri görünmesede sayfanın aktarıldığı word üzerinde değişiklik yapmaya çalışınca sorun oluyor).

Ben düz metinlerin sadece metin formatında ve tablo olanların kenarlık çizgileri ile aktarılmasını istiyorum. Bunun için 1’den 18. Satıra kadar kenarlık çizgisi olmadan salt metin olarak,tablo olan 19 ‘dan 31. Satıra kadar tablo olarak ve kenarlık çizgisi ile,46.satır ve sonrasının ise metin olarak aktarılmasını istiyorum.
Yanlız metin olarak aktarılanlarda excelde koyu olarak yazılmış başlık varsa wordde de koyu olarak yazılması gerekli.Yani metinlerin formatı bozulmamalı.

3- Verdiğiniz kodlarla worde aktarıldığında sayfa numarası eklenemiyor. Bununla ilgilide bir kod varsa buna da ihtiyacım var.

İlginiz, sabrınız ve emeğiniz için çok teşekkür ederim.

örnek dosyayı ekledim.

 

[tensinor]

".Content.Paste" kodunu ".Content.PasteAndFormat 16" olarak değiştirdim. Timesnewroman olarak yazıyor. Ancak worde atıldığında sayfa numaraları hala verilemiyor. Çalışmam excel ile ilgili makroyu çok az biliyorum.

Yardımlarınızı bekliyorum. Teşekkür ederim.

 

[tensinor]

internetten aşağıdaki kodları buldum. Sayfa numaralarını dip not olarak ekliyor. Yanlız iki sorunum var
1- Tüm sayfalar için dipnot ekliyor. Sadece aktif olan sayfa için eklemesi gerekiyor
2-8. mesajda yazılı kod ile birleştiremiyorum.
İlgilenen olursa sevinirim.

Sub dipnotekleme()
' bütün çalışma sayfalarına dipnot ekle
Dim ws As Worksheet
    Application.ScreenUpdating = False
    For Each ws In ActiveWorkbook.Worksheets
        Application.StatusBar = "Changing header/footer in " & ws.Name
        With ws.PageSetup
            .CenterHeader = "Sayfa &P / &N"
           End With
    Next ws
    Set ws = Nothing
    Application.StatusBar = False
End Sub

8. mesajda yazan ve birleştirilmesini istediğim kod ise aşağıda yer almakta:

Sub Aktif_Olan_Excel_Sayfasini_Word_Dokumani_Yap()
    
    Dim appWord As Word.Application
    Dim docWord As Word.Document
    Dim fPath As String, fName As String
    Dim j As Long, calc As Long, LastRow As Long
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        calc = .Calculation
        .Calculation = xlCalculationManual
    End With
    
    fPath = ThisWorkbook.Path & "\"
    
    With ActiveSheet
        fName = .Name
        LastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
        For j = LastRow To 1 Step -1
            .Rows(j).Hidden = .Cells(j, 1) = 0
        Next j
        .UsedRange.Copy
    End With
    Set appWord = New Word.Application
    With appWord
        .Visible = True
        Set docWord = .Documents.Add
        With docWord
            .Content.Paste
            .SaveAs fPath & fName & ".docx", FileFormat:=wdFormatDocumentDefault
            .Close
        End With
        .Quit
    End With
    Set wrdDoc = Nothing
    Set wrdApp = Nothing
    With ActiveSheet
        LastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
        For j = LastRow To 1 Step -1
            If .Rows(j).Hidden = True Then .Rows(j).Hidden = False
        Next j
    End With
    
    With Application
        .Calculation = calc
        .CutCopyMode = False
    End With

End Sub

 

[mancubus]

cevap hazır. ama yazmadan önce: 2 ay sonra geri dönüş...

 

[mancubus]

ve cevap:

aşağıdaki 2 kodu da aynı modüle atalım.
denedim sorunsuz çalıştı.

Sub Aktif_Olan_Excel_Sayfasini_Word_Dokumani_Yap_Worde_Sayfa_No_Ekle()
    
    Dim appWord As Word.Application
    Dim docWord As Word.Document
    Dim fPath As String, fName As String
    Dim j As Long, calc As Long, LastRow As Long
    Dim oRng As Object, oFooterRng1 As Object, oFooterRng2 As Object
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        calc = .Calculation
        .Calculation = xlCalculationManual
    End With
    
    fPath = ThisWorkbook.Path & "\"
    
    With ActiveSheet
        fName = .Name
        LastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
        For j = LastRow To 1 Step -1
            .Rows(j).Hidden = .Cells(j, 1) = 0
        Next j
        .UsedRange.Copy
    End With
    
    Set appWord = New Word.Application
    With appWord
        .Visible = True
        Set docWord = .Documents.Add
        With docWord
            Set oRng = .Sections(1).Footers(wdHeaderFooterPrimary).Range
            With oRng
                .Text = "Sayfa PAGE / NUMPAGES "
                Set oFooterRng1 = oRng.Words(2)
                Set oFooterRng2 = oRng.Words(4)
            End With
            fInsertFields oFooterRng1, "PAGE"
            fInsertFields oFooterRng2, "NUMPAGES"
            oRng.Fields.Update
            .Content.PasteAndFormat 16
            .SaveAs fPath & fName & ".docx", FileFormat:=wdFormatDocumentDefault
            '.Close
        End With
        '.Quit
    End With
    
    Set wrdDoc = Nothing
    Set wrdApp = Nothing
    
    With ActiveSheet
        LastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
        For j = LastRow To 1 Step -1
            If .Rows(j).Hidden = True Then .Rows(j).Hidden = False
        Next j
    End With
    
    With Application
        .Calculation = calc
        .CutCopyMode = False
    End With

End Sub






Sub fInsertFields(oRng As Object, Optional strText As String)
'http://answers.microsoft.com/en-us/office/forum/office_2007-word/insert-page-number-in-footer-using-vba/b3925502-3663-47d3-b41c-256157bc631c?msgId=f9fb443d-c4a7-40ab-a208-4acc2d713dd3
    
    Const wdFieldEmpty = -1
    With oRng
        'Find the expression and add a field around it
        With .Find
            .Text = strText
            .MatchCase = True
            .MatchWholeWord = True
            While .Execute
                oRng.Fields.Add oRng, wdFieldEmpty, , False
                oRng.Collapse wdCollapseEnd
            Wend
        End With
    End With
lbl_Exit:
    Exit Sub
End Sub

 

[tensinor]

Öncelikle çok teşekkür ederim .Kodlar tam istediğim gibi. İki ay evel mesaj yazacaktım ancak o zaman sorunun ne olduğu hakkında hiçbir fikrim olmadığından yazamadım. Kodlar çok makbule geçti.Tam ihtiyacıma göre. Çok teşekkürler.

 

[mancubus]

rica ederim.

sıkıntı yok. fakat ne yapmışım, nasıl yapmışım zaman geçince unutuyor insan. o sebeple biraz takılayım istedim

 

[askm]

Aşağıdaki satırda hata veriyor.
Dim appWord As Word.Application

 

[Emre Çinkılınç]

Konu üzerinden çokça zaman geçmiş. Ancak Sayın mancubus açtığım bir konu buna çok benzer ancak yapamıyorum bir türlü. Sizden ricam yardımcı olur musunuz? http://www.excel.web.tr/f48/excelden-makro-ile-worde-aktarma-t170642.html#post930689