Excel dosyasından word dosyasına tablo aktarma

[ASLAN7410]

Merhaba hayırlı geceler.

Ekte gönderdiğim rar klasörü içerisinde ÇALIŞMA isimli word dosyam var, ÖRNEK isimli excel dosyam var.

Yapmak istediğim excel dosyasındaki G-1, G-2, B-1, B-2,U1 ve DEFTER isimli sayfalardaki tabloları butonla ÇALIŞMA isimli word dosyasındaki ilgili yerlere yapıştırmak. Burada sütun sayıları belli ancak satır sayıları belli değil.

Excel dosyasındaki hangi sayfadaki butona basarsam o sayfadaki tabloyu, word sayfasındaki ilgili yere yapıştırmasını istiyorum.

Yardım eder misiniz?

http://dosya.co/emswpgsndn9t/Yeni_klasör.rar.html

 

[ASLAN7410]

Sayın yönetici arkadaşlar bu işlem benim için gerçekten çok önemli, konu günceldir.

Yardımcı olur musunuz?

 

[PLİNT]

Merhaba
"G1" sayfası için aşağıdaki gibi olur diğer sayfalara uyarlayabilirmisiniz?
(belirtmemişsiniz;başlıklar dahil, ve her sayfa ayrı gidecek sanırım)

[SIZE="2"]Sub G1()
Dim s, y, u
Dim a As Long
Dim b As Integer
Set s = CreateObject("Word.Application")
Set y = s.Documents.Open(ThisWorkbook.Path & "\ÇALIŞMA.docx")
s.Visible = True
 Set u = y.Range.tables(1)
 For a = 1 To ActiveSheet.Cells(Rows.Count, "B").End(3).Row
 If u.Rows.Count < a Then u.Rows.Add
 For b = 2 To 8
 u.Rows(a).Cells(b - 1).Range.Text = ActiveSheet.Cells(a, b).Value
 If b = 8 Then
 u.Rows(a).Cells(8).Range.Text = ActiveSheet.Cells(a, "M").Value
 Exit For
 End If: Next: Next
End Sub[/SIZE]

 

[ASLAN7410]

Sayın PLİNT ellerinize sağlık kod gayet güzel çalışıyor, evet her sayfa ayrı aktarılacak, ancak tek bir butona da bağlanabilir.

Bu kod sadece G1 sayfasındaki tabloyu aktarıyor, kod üzerinde bazı yerleri değiştirmeye çalıştım G-2, B-1,B-2,U1 ve DEFTER sayfalarındaki tabloları aktaramadım.

 

[PLİNT]

Merhaba
Tek butonla sayfaların hepsi aktarılacaksa ek dosyayı inceleyiniz;
http://s6.dosya.tc/server8/v1ix19/worlde_aktar.zip.html
Aktarılmayacak sütunlar örneğinizdeki gibi gizlenmiş olmalı.
"Docx" dosyanızın; kod bulunan dosyanın yanında ve kapalı olacağını varsayarak.

[SIZE="2"]Private Sub CommandButton1_Click()
Dim s, y, u
Dim a, x, n As Long
Dim b, k As Integer
Dim sayf, col As Variant
sayf = Array("G-1", "G-2", "B-1", "B-2", "U1", "DEFTER")
col = Array(8, 2, 6, 2, 8, 7)
Set s = CreateObject("Word.Application")
Set y = s.Documents.Open(ThisWorkbook.Path & "\ÇALIŞMA.docx")
s.Visible = True
 For x = 0 To UBound(sayf)
Set u = y.Range.tables(x + 1)
n = Sheets(sayf(x)).[A:D].Find("*", , , , xlByRows, xlPrevious).Row
 For a = 1 To n
If u.Rows.Count < a Then u.Rows.Add
k = 0
 For b = 1 To col(x)
10:
k = k + 1
If Sheets(sayf(x)).Columns(k).EntireColumn.Hidden = False Then
u.Rows(a).Cells(b).Range.Text = Sheets(sayf(x)).Cells(a, k).Value
Else
GoTo 10
End If
 Next: Next: Next
MsgBox "Sayfaların aktarımı bitti"
End Sub [/SIZE]

 

[ASLAN7410]

Sayın PLİNT ellerinize sağlık çok teşekkür ediyorum, tam istediğim gibi oldu, Allah razı olsun.

Hayırlı geceler, hayırlı çalışmalar diliyorum.