Word belgesindeki bilgileri farklı dosyalara aktarma

[ucan39]

Hocam ekteki uc belgesindekilerle çok uğraştım yapamadım yardım debilirmisiniz.

 

[ucan39]

sn leumruk açıkladım

2 adım çok önemli hocam

 

[leumruk]

Merhaba,
3. isteğinizi anlayamadım. 2. isteğinizi de anladığım oranda yaptım.

Sub xl_aktar()
Application.ScreenUpdating = False
dosya = Dir(ThisDocument.Path & "\ista.xls*")
If dosya <> "" Then
Set xl = CreateObject("excel.Application")
xl.Visible = False
xl.Application.workbooks.Open ThisDocument.Path & "\" & dosya
Set xlf = xl.ActiveWorkbook.ActiveSheet
Sat = xlf.Cells(xlf.Rows.Count, 1).End(3).Row + 1
Set tbl = ActiveDocument.Tables(1)
tbl.Cell(1, 1).Range.Copy: xlf.Cells(Sat, 1).Select: xlf.PasteSpecial 3
tbl.Cell(2, 2).Range.Copy: xlf.Cells(Sat, 2).Select: xlf.PasteSpecial 3
tbl.Cell(3, 3).Range.Copy: xlf.Cells(Sat, 3).Select: xlf.PasteSpecial 3
xlf.Cells(Sat, 5) = Now

Set ds = CreateObject("Scripting.FileSystemObject")
kls = xlf.Cells(Sat, 1) & "-" & xlf.Cells(Sat, 2) & "-" & xlf.Cells(Sat, 3)
If ds.FolderExists(ActiveDocument.Path & "\DENEME\" & kls) = False Then
ds.CreateFolder ActiveDocument.Path & "\DENEME\" & kls
End If

ActiveDocument.Save
ds.copyfile ActiveDocument.Path & "\bba.docm", ActiveDocument.Path & "\DENEME\" & kls & "\" & kls & ".docm"

xl.ActiveWorkbook.Close True
xl.Application.Quit

Application.ScreenUpdating = True
MsgBox "Aktarım tamamlandı.", vbInformation, "l e u m r u k"
End If
End Sub

 

[ucan39]

hocam

sn leumruk çok teşekkürler çok iii olmuş 3. adımda kopyalanacak hücreleri uca belgesinde istenen hücrelere yerleştirecek. olursa tabi. tekrar teşekkürler emeğinize sağlık

 

[leumruk]

Sn. ucan39,
uca belgesinde hiçbir şey yok, dolayısıyla hücre de yok. uca belgesini gözden geçirir misiniz?

 

[ucan39]

Sn leumruk

Hocam ekledim ilgilendiğiniz için teşekkürler uca içinde yazıyor

 

[leumruk]

Merhaba,
Aşağıdaki kodu kullanırsanız ismi wordden alacaktır. 3. istediğinizi hala anlamış değilim. İlgili yerlere kopyalanacak demişsiniz. İlgili yerlerin neresi olduğuna ben mi karar vereceğim?

 

[ucan39]

hocam 3. adımda bba içindeki kopyalanan hücreleri uca içinde belirtilen hücrelere yapıştıracak sonra uca belgesini kopyalayıp yeni yarattığımız klasörün içine kaydedecek çıkacak 2. adımda yaratılan klasör içine yani en son eklediğim proje de belirttim sn.leumruk

 

[ucan39]

bide hocam aşağıdaki demişsiniz ama kod yok

 

[leumruk]

Merhaba,
Aşağıdaki kodu kullanırsanız ismi wordden alacaktır. 3. istediğinizi hala anlamış değilim. İlgili yerlere kopyalanacak demişsiniz. İlgili yerlerin neresi olduğuna ben mi karar vereceğim?

Sub xl_aktar()
Application.ScreenUpdating = False
Dim kls As String
dosya = Dir(ThisDocument.Path & "\ista.xls*")
If dosya <> "" Then
Set xl = CreateObject("excel.Application")
xl.Visible = False
xl.Application.workbooks.Open ThisDocument.Path & "\" & dosya
Set xlf = xl.ActiveWorkbook.ActiveSheet
Sat = xlf.Cells(xlf.Rows.Count, 1).End(3).Row + 1
Set tbl = ActiveDocument.Tables(1)

tbl.Cell(1, 1).Range.Copy: xlf.Cells(Sat, 1).Select: xlf.PasteSpecial 3
tbl.Cell(2, 2).Range.Copy: xlf.Cells(Sat, 2).Select: xlf.PasteSpecial 3
tbl.Cell(3, 3).Range.Copy: xlf.Cells(Sat, 3).Select: xlf.PasteSpecial 3
xlf.Cells(Sat, 5) = Now

Set ds = CreateObject("Scripting.FileSystemObject")
bir = Left(tbl.Cell(1, 1).Range, Len(tbl.Cell(1, 1).Range) - 2)
iki = Left(tbl.Cell(2, 2).Range, Len(tbl.Cell(2, 2).Range) - 2)
uc = Left(tbl.Cell(3, 3).Range, Len(tbl.Cell(3, 3).Range) - 2)
kls = bir & "-" & iki & "-" & uc

If ds.FolderExists(ActiveDocument.Path & "\DENEME\" & kls) = False Then
ds.CreateFolder ActiveDocument.Path & "\DENEME\" & kls
End If

ActiveDocument.Save
ds.copyfile ActiveDocument.Path & "\bba.docm", ActiveDocument.Path & "\DENEME\" & kls & "\" & kls & ".docm"

Application.Documents.Open ThisDocument.Path & "\uca.docx"
Set tbl = ActiveDocument.Tables(1)
tbl.Cell(3, 1).Range = bir
tbl.Cell(3, 2).Range = iki
tbl.Cell(3, 3).Range = uc
ActiveDocument.SaveAs ActiveDocument.Path & "\DENEME\" & kls & "\uca-" & kls & ".docx"
ActiveDocument.Close

xl.ActiveWorkbook.Close True
xl.Application.Quit

Application.ScreenUpdating = True
MsgBox "Aktarım tamamlandı.", vbInformation, "l e u m r u k"
End If
End Sub

 

[ucan39]

sn leumruk ekledim uca da yazıyor

Hocam bba tablosunda seçilenleri uca bu belge içinde ilgili yerlere (Şu anda Ahmet veli ve sayın bulunduğu hücrelere ) yerleştirecek bu sayfayı tamamını kopyalayıp yeni açtığımız klasörün(2.Adımda oluşturulan Ahmet veli say klasörünün içine) içine yapıştıracak kaydedip çıkacak siz kendi istediğiniz hücreyide seçebilirsiniz. hocam

 

[leumruk]

Sn ucan 10. mesajdaki örneği deneyiniz.

 

[ucan39]

Sn leumruk süpersiniz çok teşekkürler tam olmuş ellerine sağlık hocam ellerin dert görmesin

 

[ucan39]

Sn Leumruk bu dosyaya bakabilirmisiniz?

 

[leumruk]

Merhaba,

Sub Aktar()
yol = ThisDocument.Path & "\"
Set wd = CreateObject("word.Application")
wd.Application.Documents.Open yol & "uhu.docx"
wd.Visible = True

uzn = Len(ActiveDocument.Tables(1).Cell(3, 3).Range) - 1
mtn = Left(ActiveDocument.Tables(1).Cell(3, 3).Range, uzn)

wd.ActiveDocument.Tables(1).Cell(1, 3).Range.Words(7).Select
wd.Selection.MoveRight Unit:=wdCharacter, Count:=1
wd.Selection = mtn

uzn = Len(ActiveDocument.Tables(1).Cell(2, 2).Range) - 1
mtn = Left(ActiveDocument.Tables(1).Cell(2, 2).Range, uzn)

wd.ActiveDocument.Tables(1).Cell(1, 3).Range.Words(6).Select
wd.Selection.MoveRight Unit:=wdCharacter, Count:=1
wd.Selection = mtn

MsgBox "İşlem tamamlandı.", vbInformation, "l e u m r u k"
End Sub

 

[ucan39]

Sn leumruk

Elleriniz dert görmesin hocam, çok teşekkürler. Allah kolaylıklar versin.