2 dosya arasına veri aktarma

[pigment79]

İhsan Bey,
Otomatik kapatma yapmasın. Çünkü ben yaklaşık 10 tane sipariş bir anda programlar açıkken hazırlıyorum. Her defasında Kutu üretimi açmak beni yavaşlatıyor. Teşekkürler.

 

[pigment79]

2 Dosya arasında veri aktarma

Değerli arkadaşlar daha önce burda İhsan beyin yazdığı makro işimi gördü. Ancak; aynı makronun
Zentiva dosyasındaki BH1....BH kırmız hücrelerini de aynı şekilde kutu üretim 2001 e aktarmasını istiyorum.

Daha önceki makroya ilave olabilir.

 

[İhsan Tank]

İhsan Bey,
Otomatik kapatma yapmasın. Çünkü ben yaklaşık 10 tane sipariş bir anda programlar açıkken hazırlıyorum. Her defasında Kutu üretimi açmak beni yavaşlatıyor. Teşekkürler.

10 tane girişi yaptıktan sonra kod'u çalıştırın o zaman. Dosya açık kaldığında sorun yaşarsınız diye döylüyorum

 

[İhsan Tank]

Değerli arkadaşlar daha önce burda İhsan beyin yazdığı makro işimi gördü. Ancak; aynı makronun
Zentiva dosyasındaki BH1....BH kırmız hücrelerini de aynı şekilde kutu üretim 2001 e aktarmasını istiyorum.

Daha önceki makroya ilave olabilir.

Bu sorunuzun yanıtına gelince

Option Explicit
Sub aktar()
Dim ts, kaplan, trabzonspor, bordo, mavi, hamsi, kral
kaplan = MsgBox("Aktarıma Başlıyorum", vbYesNo, "Onay")
If kaplan = vbNo Then Exit Sub
Application.ScreenUpdating = False
Set bordo = CreateObject("wscript.Shell")
trabzonspor = bordo.SpecialFolders.Item("Desktop")
mavi = "KUTU_URETIM 2011.xls"
hamsi = ActiveWorkbook.Name
kral = ActiveSheet.Name
Workbooks.Open (trabzonspor & "\Üretim\" & mavi)
For ts = 2 To Workbooks(mavi).Sheets("DOSYA").Cells(65536, "A").End(xlUp).Row
If Workbooks(mavi).Sheets("DOSYA").Cells(ts, "A") = Workbooks(hamsi).Sheets(kral).Range("E6") Then
Workbooks(mavi).Sheets("DOSYA").Cells(ts, "F") = WorksheetFunction.Round(Workbooks(hamsi).Sheets(kral).Range("AA6"), 0)
Workbooks(mavi).Sheets("DOSYA").Cells(ts, "G") = WorksheetFunction.Round(Workbooks(hamsi).Sheets(kral).Range("BH1"), 0)
Workbooks(mavi).Sheets("DOSYA").Cells(ts, "H") = WorksheetFunction.Round(Workbooks(hamsi).Sheets(kral).Range("BH2"), 0)
Workbooks(mavi).Sheets("DOSYA").Cells(ts, "I") = WorksheetFunction.Round(Workbooks(hamsi).Sheets(kral).Range("BH3"), 0)
Workbooks(mavi).Sheets("DOSYA").Cells(ts, "J") = WorksheetFunction.Round(Workbooks(hamsi).Sheets(kral).Range("BH4"), 0)
Workbooks(mavi).Sheets("DOSYA").Cells(ts, "K") = WorksheetFunction.Round(Workbooks(hamsi).Sheets(kral).Range("BH5"), 0)
End If
Next
Workbooks(mavi).Save
Workbooks(mavi).Close
Application.ScreenUpdating = True
MsgBox "Aktarım Tamamlandı", vbInformation, "Bitiş"
End Sub

Bu kod işinizi görür.

 

[pigment79]

İhsan Bey, çok teşekkür ederim.
Zentivadaki Montaj fire %olarak yazılmış. bu kutu üretim Yanlız BH3'e " 0 " olarak aktarılıyor.

 

[İhsan Tank]

İhsan Bey, çok teşekkür ederim.
Zentivadaki Montaj fire %olarak yazılmış. bu kutu üretim Yanlız BH3'e " 0 " olarak aktarılıyor.

Merhaba

Option Explicit
Sub aktar()
Dim ts, kaplan, trabzonspor, bordo, mavi, hamsi, kral
kaplan = MsgBox("Aktarıma Başlıyorum", vbYesNo, "Onay")
If kaplan = vbNo Then Exit Sub
Application.ScreenUpdating = False
Set bordo = CreateObject("wscript.Shell")
trabzonspor = bordo.SpecialFolders.Item("Desktop")
mavi = "KUTU_URETIM 2011.xls"
hamsi = ActiveWorkbook.Name
kral = ActiveSheet.Name
Workbooks.Open (trabzonspor & "\Üretim\" & mavi)
For ts = 2 To Workbooks(mavi).Sheets("DOSYA").Cells(65536, "A").End(xlUp).Row
If Workbooks(mavi).Sheets("DOSYA").Cells(ts, "A") = Workbooks(hamsi).Sheets(kral) _
.Range("E6") Then
Workbooks(mavi).Sheets("DOSYA").Cells(ts, "F") = WorksheetFunction.Round(Workbooks _
(hamsi).Sheets(kral).Range("AA6"), 0)
Workbooks(mavi).Sheets("DOSYA").Cells(ts, "G") = WorksheetFunction.Round(Workbooks _
(hamsi).Sheets(kral).Range("BH1"), 0)
Workbooks(mavi).Sheets("DOSYA").Cells(ts, "H") = WorksheetFunction.Round(Workbooks _
(hamsi).Sheets(kral).Range("BH2"), 0)
Workbooks(mavi).Sheets("DOSYA").Cells(ts, "I") = Workbooks(hamsi).Sheets(kral).Range _
("BH3")
Workbooks(mavi).Sheets("DOSYA").Cells(ts, "J") = WorksheetFunction.Round(Workbooks _
(hamsi).Sheets(kral).Range("BH4"), 0)
Workbooks(mavi).Sheets("DOSYA").Cells(ts, "K") = WorksheetFunction.Round(Workbooks _
(hamsi).Sheets(kral).Range("BH5"), 0)
End If
Next
Workbooks(mavi).Save
Workbooks(mavi).Close
Application.ScreenUpdating = True
MsgBox "Aktarım Tamamlandı", vbInformation, "Bitiş"
End Sub

 

[pigment79]

İhsa Bey' den ve paylaşımcı tüm insanlardan Allah razı olsun. Sevgi ve saygılarımla.

 

[İhsan Tank]

İhsa Bey' den ve paylaşımcı tüm insanlardan Allah razı olsun. Sevgi ve saygılarımla.

Allah Hepimizden Razı Olsun
:yazici: