• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Macro ile diğer dosyadan bilgileri ilgili alanlara almak

  • Konbuyu başlatan Konbuyu başlatan levoni
  • Başlangıç tarihi Başlangıç tarihi
L

levoni

Katılım
6 Temmuz 2011
Mesajlar
127
Excel Vers. ve Dili
2007 English
Arkadaşlar Merhaba,
Günlük rutin işlemlerde çok fazla zaman alan bir konuda sizlerin yardımınıza ihtiyacım var.Yardımcı olabilirseniz çok memnun olurum.
Yapmak istediğim şey şu;
"Data" isimli dosyada bulunan ilgili sütunları "Boş_Aktarım Formatı_1" dosyasındaki ilgili sütunlara macro yardımı ile yapıştırmak istiyorum.Hangi sütunların nereye yapıştırılacağı "Boş_Aktarım Formatı_1" dosyasının içerisine yazdım.

Macro çalıştıktan sonra olması gereken sonuç dosyasını size yol göstermesi açısından ekte bilgilerinize sunuyorum.

Yardımlarınız için şimdiden çok teşekkür ediyorum. İyi çalışmalar
 

Ekli dosyalar

Merhaba
Bu dosyalar aynı klasör içinde mi olacak. Yoksa başka yerde mi olacak_?
Başka yerde olacak ise lütfen yol bilgisi verin.
 
Sayın "asi_kral_1967" ilginiz için çok teşekkür ederim.Aslında ayrı bir dosya olarak masa üstüne atsa süper olur.

İyi çalışmalar
 
levoni' Alıntı:
Sayın "asi_kral_1967" ilginiz için çok teşekkür ederim.Aslında ayrı bir dosya olarak masa üstüne atsa süper olur.

İyi çalışmalar
Genişletmek için tıkla ...

Yani kopyası masaüstünde olacak. Tamam onu hallederiz ama dosyanın asılları nerede onu öğrenmek istiyorum ben. Şimdi biri farklı biri farklı yerdeyse bunu makro ile tanıtmak gerek ki hata vermesin
 
Sayın asi_kral_1967 ,
Dosyanın asılları masaüstünde "Aktarım" isimli bir klasörün içerisinde olacak.Birde çıktı olarak vereceği sonuç dosyasına tarih saat dakika bilgisi vermek mümkünmü.Sizi yoracaksa uğraşmayın.
Umarım eksik bilgiler vererek sizi uğraştırmıyorumdur.
 
levoni' Alıntı:
Sayın asi_kral_1967 ,
Dosyanın asılları masaüstünde "Aktarım" isimli bir klasörün içerisinde olacak.Birde çıktı olarak vereceği sonuç dosyasına tarih saat dakika bilgisi vermek mümkünmü.Sizi yoracaksa uğraşmayın.
Umarım eksik bilgiler vererek sizi uğraştırmıyorumdur.
Genişletmek için tıkla ...

Merhaba
Verileri aldıktan sonra ne yapacak şimdi onu söyleyin. Masaüstüne bir tane kopyası mı gelecek_? Kopyası olacaksa adı ne olacak. Sonuç dosyası nedir onu anlamadım.
 
Yapmak istediğim şey şu;
Bir macro düşünün "Data" isimli dosyada bulunan ilgili sütünları "Boş Aktarım Formatı_1" isimli dosyanın içerisinde bulunan ilgili alanlara yapıştırması veya aynı formatta yeni bir excel üretmesi gerekiyor .Diğer bir ifadeyle benim için asıl olan "boş aktarım-1" isimli dosya formatında bir dosya oluşturmam lazım.
Verileri Data isimli dosyadan alacak aynı boş aktarım formatında ki alanlara kopyalayacak veya aynı formatta yeni bir dosya üretecek.Bu üreteceği excelin adı "Sonuç_Format_09052012" olabilir
 
sonuç dosyası size örnek olsun diye ben manuel hazırladım.Yani macro bu işlemi yapmış olsaydı aynı bu şeklilde bir dosya olması lazımdı.

Örneğin "Data" isimli dosyada B sütununda bulunan bilgileri yeni oluşturulacak excel dosyasında "A" sütununa yazması gerekiyor
 
levoni' Alıntı:
sonuç dosyası size örnek olsun diye ben manuel hazırladım.Yani macro bu işlemi yapmış olsaydı aynı bu şeklilde bir dosya olması lazımdı.

Örneğin "Data" isimli dosyada B sütununda bulunan bilgileri yeni oluşturulacak excel dosyasında "A" sütununa yazması gerekiyor
Genişletmek için tıkla ...

Merhaba
Boş bir module kopyalayın ve deneyin.
Kod: 
Option Explicit
Sub verileri_çek()
'Konu       :   Aynı Klasördeki Başka Dosyadan Veri Çek
'Mail       :   m.batu.1967@gmail.com
'Msn        :   m.batu.1967@hotmail.com.tr
'Skype      :   m.batu.1967
'Coder By   :   asi_kral_1967
Dim ktp As Workbook, ex As Excel.Application, _
asi As Worksheet, kral As Worksheet, a As Long, b As Long, _
c As String, yol As String, d As String, e, f As String
Set ex = CreateObject("Excel.Application")
Set e = CreateObject("Wscript.Shell")
f = e.specialfolders.Item("Desktop")
Application.ScreenUpdating = False
ex.Visible = False
c = ActiveWorkbook.Name
b = 2
yol = ThisWorkbook.Path & "\"
Set asi = Workbooks(c).Sheets("Sheet1")
d = "Data.xls"
Set ktp = ex.Workbooks.Open(yol & d)
Set kral = ktp.Sheets("Sayfa1")
asi.Range("A2:Ad" & Rows.Count).ClearContents
For a = 2 To kral.Cells(Rows.Count, "B").End(xlUp).Row
asi.Cells(b, "A") = kral.Cells(a, "B"): asi.Cells(b, "B") = kral.Cells(a, "D")
asi.Cells(b, "C") = kral.Cells(a, "C"): asi.Cells(b, "V") = kral.Cells(a, "E")
asi.Cells(b, "U") = kral.Cells(a, "F"): asi.Cells(b, "F") = kral.Cells(a, "I")
asi.Cells(b, "E") = kral.Cells(a, "G") & " " & kral.Cells(a, "H")
asi.Cells(b, "G") = kral.Cells(a, "K"): asi.Cells(b, "K") = kral.Cells(a, "L")
asi.Cells(b, "J") = kral.Cells(a, "M"): asi.Cells(b, "H") = kral.Cells(a, "P")
If kral.Cells(a, "I") = "ŞUBESİ" Then
asi.Cells(b, "O") = kral.Cells(a, "E") & " Nolu Serinin Şubeden Alınması"
Else
asi.Cells(b, "O") = kral.Cells(a, "E") & " Nolu Serinin Adresten Alınması"
End If: b = b + 1: Next
ktp.Close
Workbooks(c).Save
ActiveWorkbook.SaveAs (f & "\Sonuç_Format_" & Format(Now, "ddmmyyyy")) & ".xls"
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı" & vbLf & Application.UserName, _
vbInformation, "asi_kral_1967"
End Sub
Dosyanız Ekte.
 

Ekli dosyalar

Sayın asi_kral_1967 çok acil çıkmam gerektiği için pc yi acilen kapatıyorum.Çok teşekkür ederim.Netin karşına geçince ilk işim bakacağım.
Çok tşk ler elinize sağlık.
 
levoni' Alıntı:
Sayın asi_kral_1967 çok acil çıkmam gerektiği için pc yi acilen kapatıyorum.Çok teşekkür ederim.Netin karşına geçince ilk işim bakacağım.
Çok tşk ler elinize sağlık.
Genişletmek için tıkla ...

Deneyip bilgi verirseniz sevinirim.
Kolay Gelsin.
 
Sayın asi_kral_1967 öncelikle elinize sağlık tşk ederim.Macroyu inceledim gayet güzel çalışıyor.Bir iki ufak düzenlemeyi ben kendim yaptım.Size kolonların yerini yanlış verdiğim için haklı olarak yanlış getiriyordu onları sizin kodunuz üzerinden değiştirdim.
Bunun dışında bir iki düzenleme yapabilme imkanımız olursa çok daha güzel bir macro olacak.eğer vakit alırsa hiç uğraşmayın.
bunlardan 1.si "Veriyi Çek" butonuna bastığımızda bize hangi dosyayı seçeceğimizi sorması mümkün mü ?. Şuanki çalışma mantığında "Data" isimli dosyayı arıyor ve işlem yapıyor.Eğer dosyayı ben macroya gösterme şansım olursa çok daha iyi olur.
2.si Macro işlemini yapıp tamamladıktan sonra oluşan sonuç dosyası "macrolu" bir dosya oluyor.Bu oluşan dosyanın macrosuz oluşması mümkünmü.

Düzenlemeden sonra kodların son hali şu şekildedir.

Kod: 
Option Explicit
Sub verileri_çek()
'Konu       :   Aynı Klasördeki Başka Dosyadan Veri Çek
'Mail       :   m.batu.1967@gmail.com
'Msn        :   m.batu.1967@hotmail.com.tr
'Skype      :   m.batu.1967
'Coder By   :   asi_kral_1967
Dim ktp As Workbook, ex As Excel.Application, _
asi As Worksheet, kral As Worksheet, a As Long, b As Long, _
c As String, yol As String, d As String, e, f As String
Set ex = CreateObject("Excel.Application")
Set e = CreateObject("Wscript.Shell")
f = e.specialfolders.Item("Desktop")
Application.ScreenUpdating = False
ex.Visible = False
c = ActiveWorkbook.Name
b = 2
yol = ThisWorkbook.Path & "\"
Set asi = Workbooks(c).Sheets("Sheet1")
d = "Data.xls"
Set ktp = ex.Workbooks.Open(yol & d)
Set kral = ktp.Sheets("Sayfa1")
asi.Range("A2:Ad" & Rows.Count).ClearContents
For a = 2 To kral.Cells(Rows.Count, "B").End(xlUp).Row
asi.Cells(b, "A") = kral.Cells(a, "B"): asi.Cells(b, "B") = kral.Cells(a, "D")
asi.Cells(b, "C") = kral.Cells(a, "C"): asi.Cells(b, "V") = kral.Cells(a, "E")
asi.Cells(b, "G") = kral.Cells(a, "J"): asi.Cells(b, "H") = kral.Cells(a, "P")
asi.Cells(b, "U") = kral.Cells(a, "F"): asi.Cells(b, "F") = kral.Cells(a, "I")
asi.Cells(b, "E") = kral.Cells(a, "G") & " " & kral.Cells(a, "H")
asi.Cells(b, "K") = kral.Cells(a, "K"): asi.Cells(b, "J") = kral.Cells(a, "L")
 
If kral.Cells(a, "I") = "ŞUBESİ" Then
asi.Cells(b, "O") = kral.Cells(a, "E") & " Nolu Serinin Şubeden Alınması"
Else
asi.Cells(b, "O") = kral.Cells(a, "E") & " Nolu Serinin Adresten Alınması"
End If: b = b + 1: Next
ktp.Close
Workbooks(c).Save
ActiveWorkbook.SaveAs (f & "\Sonuç_Format_" & Format(Now, "ddmmyyyy")) & ".xls"
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı" & vbLf & Application.UserName, _
vbInformation, "asi_kral_1967"
End Sub


Teşekkürler iyi çalışmalar
 
Merhaba
Dosya adını mı yazacaksınız yoksa seçecek misiniz_? Adını yazmak isterseniz bir Inputbox ile bu işlemi yapabilir. Kullanışlı olur. Ayrıca.
Diğer sorunuz ise aklıma geldi ama istemediğiniz için yapmamıştım. Denemek lazım moduldeki kodu silmeyi. 2003 kullandığınız için mecburen module silmesi yaptırmamız gerekecek büyük bir ihtimalle üstü versiyon kullansaydınız normal dosya şeklinde kayıt yaptırır işlemi tamamlardık böylece tüm makrolar otomatik silinirdi.
 
Eğer sizi uğraştırmayacak ve vaktinizi çok almayacak ise Dosya seçmek isterim.

diğer konuda ben excel 2007 kullanıyorum 2003 değil .
 
levoni' Alıntı:
Eğer sizi uğraştırmayacak ve vaktinizi çok almayacak ise Dosya seçmek isterim.

diğer konuda ben excel 2007 kullanıyorum 2003 değil .
Genişletmek için tıkla ...

Merhaba
Kodu bununla değiştirip dener misiniz_?
Tek sıkıntı yolu bulamıyor size seçim yaptırıyor. Onu da halledersem kodu güncellerim.
Kod: 
Sub verileri_çek()
'Konu       :   Aynı Klasördeki Başka Dosyadan Veri Çek
'Mail       :   m.batu.1967@gmail.com
'Msn        :   m.batu.1967@hotmail.com.tr
'Skype      :   m.batu.1967
'Coder By   :   asi_kral_1967
Dim ktp As Workbook, ex As Excel.Application, _
asi As Worksheet, kral As Worksheet, a As Long, b As Long, _
c As String, yol As String, d, e, f As String, g
Set ex = CreateObject("Excel.Application")
Set e = CreateObject("Wscript.Shell")
f = e.SpecialFolders.Item("Desktop")
Application.ScreenUpdating = False
ex.Visible = False
c = ActiveWorkbook.Name
b = 2
Set asi = Workbooks(c).Sheets("Sheet1")
yol = ThisWorkbook.Path
ChDir (yol)
d = Application.GetOpenFilename(filefilter:="Excel Workbooks,*.xls", Title:="asi_kral_1967", MultiSelect:=False)
g = Dir(d)
If g <> "" Then
CreateObject("Shell.Application").Open (g)
End If
Set ktp = ex.Workbooks.Open(yol & "\" & g)
Set kral = ktp.Sheets("Sayfa1")
asi.Range("A2:Ad" & Rows.Count).ClearContents
For a = 2 To kral.Cells(Rows.Count, "B").End(xlUp).Row
asi.Cells(b, "A") = kral.Cells(a, "B"): asi.Cells(b, "B") = kral.Cells(a, "D")
asi.Cells(b, "C") = kral.Cells(a, "C"): asi.Cells(b, "V") = kral.Cells(a, "E")
asi.Cells(b, "G") = kral.Cells(a, "J"): asi.Cells(b, "H") = kral.Cells(a, "P")
asi.Cells(b, "U") = kral.Cells(a, "F"): asi.Cells(b, "F") = kral.Cells(a, "I")
asi.Cells(b, "E") = kral.Cells(a, "G") & " " & kral.Cells(a, "H")
asi.Cells(b, "K") = kral.Cells(a, "K"): asi.Cells(b, "J") = kral.Cells(a, "L")
If kral.Cells(a, "I") = "ŞUBESİ" Then
asi.Cells(b, "O") = kral.Cells(a, "E") & " Nolu Serinin Şubeden Alınması"
Else
asi.Cells(b, "O") = kral.Cells(a, "E") & " Nolu Serinin Adresten Alınması"
End If: b = b + 1: Next
ktp.Close
Workbooks(c).Save
ActiveWorkbook.SaveAs (f & "\Sonuç_Format_" & Format(Now, "ddmmyyyy")) & ".xls"
c = ActiveWorkbook.Name
With Workbooks(c).VBProject
.VBComponents.Remove .VBComponents("Module1")
End With
Workbooks(c).Save
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı" & vbLf & Application.UserName, _
vbInformation, "asi_kral_1967"
End Sub
 
Son düzenleme:
Merhaba,
kodu değiştirdim şu şekilde bir hata verdi ;
"Run time error 1004 programatic access to Visual Basic is not trusted "
"Debug" butonuna bastığımda ise sarı ile işaretli bu With Workbooks(c).VBProject ksımda hata verdi.

Aslında dosyayı bana seçtirmesi hiç sorun değil hatta tam istediğim gibi. Birde aslında yukardaki hatayı veriyor ama dosyayı macrolu bir şekilde oluşturuyor.

Valla kusura bakmayın sizi çok yorduğumun farkındayım
İyi çalışmalar
 
levoni' Alıntı:
Merhaba,
kodu değiştirdim şu şekilde bir hata verdi ;
"Run time error 1004 programatic access to Visual Basic is not trusted "
"Debug" butonuna bastığımda ise sarı ile işaretli bu With Workbooks(c).VBProject ksımda hata verdi.

Aslında dosyayı bana seçtirmesi hiç sorun değil hatta tam istediğim gibi. Birde aslında yukardaki hatayı veriyor ama dosyayı macrolu bir şekilde oluşturuyor.

Valla kusura bakmayın sizi çok yorduğumun farkındayım
İyi çalışmalar
Genişletmek için tıkla ...

O noktayı atlamışım. Üstteki kodu güncelledim. Dosya yoluna otomatik gidecek şekilde böyle daha kullanışlı olacaktır.
hatanın sebebine gelince. Makro Güvenlik Ayarlarından Vba projesine güven'in tik'ini işaretlerseniz problem kalmaz.
 
Sayın asi_kral_1967 çok teşekkür ederim elinize sağlık.Sizi çok yorduk,

İyi çalışmalar
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst