• DİKKAT

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

Makro Kodunu Kopyaladığım Sayfalara Nasıl Uyarlayabilirim?

M

MiRaBiLiS

Katılım
22 Ağustos 2014
Mesajlar
49
Excel Vers. ve Dili
Ofis 365 Türkçe
Merbaha arkadaşlar,

benim elimde arkadaşıma yazdırdığım bir kodum var.

bu kodun olduğu sayfayı çoğaltıp 5 kopya yapıyorum ancak kodlar aynı kaldığı için kopya sayfalardaki verileri çekmek yerine ilk sayfamdaki veriyi çekiyor sürekli

Kod: 
Private Sub CommandButton4_Click()
CommandButton3.Enabled = True
CommandButton4.Enabled = False

Dim filter As String
Dim caption As String
Dim customerFilename As String
Dim customerWorkbook As Workbook

filter = "Text files (*.xlsm),*.xlsm"

caption = "Lütfen Dosya Seçiniz "
customerFilename = "C:\Users\Ofis1\YandexDisk\SEVKIYAT\GUNLUK.xlsm"
Set customerWorkbook = Application.Workbooks.Open(customerFilename)
Application.ScreenUpdating = False
Application.DisplayAlerts = False


For i = 6 To 38

    sat = customerWorkbook.Worksheets(1).Cells(65536, "B").End(xlUp).Row

    If ThisWorkbook.Worksheets(1).Range("E" & i).Value <> 0 Then
        customerWorkbook.Worksheets(1).Range("A" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("A3").Value
        customerWorkbook.Worksheets(1).Range("B" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("B3").Value
        customerWorkbook.Worksheets(1).Range("D" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("D3").Value
        customerWorkbook.Worksheets(1).Range("P" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("A41").Value
        customerWorkbook.Worksheets(1).Range("Q" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("C41").Value
        customerWorkbook.Worksheets(1).Range("J" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("D41").Value
        customerWorkbook.Worksheets(1).Range("K" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("E41").Value
        customerWorkbook.Worksheets(1).Range("L" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("F41").Value
        customerWorkbook.Worksheets(1).Range("M" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("H41").Value
        customerWorkbook.Worksheets(1).Range("S" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("I41").Value
        customerWorkbook.Worksheets(1).Range("T" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("B44").Value
        customerWorkbook.Worksheets(1).Range("N" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("C47").Value
        customerWorkbook.Worksheets(1).Range("R" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("M2").Value
        customerWorkbook.Worksheets(1).Range("O" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("D56").Value
       
        customerWorkbook.Worksheets(1).Range("F" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("E" & i).Value
        customerWorkbook.Worksheets(1).Range("H" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("H" & i).Value
        customerWorkbook.Worksheets(1).Range("I" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("I" & i).Value
        customerWorkbook.Worksheets(1).Range("G" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("B" & i).Value
    End If

Next i

customerWorkbook.Save
customerWorkbook.Close
MsgBox "Import İşlemi Başarıyla Tamamlandı!" & Alt _


End Sub

kodum bu, butona bastığımda belirli alanlardaki verileri farklı bir sayfaya yazıyor.

arkadaşla görüştüm, Worksheets(1) değeri ile oynarsan olabilir dedi ama debug veriyor.
geçerli sayfalarda bu kodun çalışması için nasıl değiştirebilirim.

şimdiden çok teşekkürler.
 
Kodun aşağıdaki kısmını kopyala. ondan sonra geliştirici sekmesinden Visual Basic e tıkla açılan pencerede solda sayfların listesi bulunur.
Hangi sayfada kullanmak istiyorsan çift tıkla. Sonrasında açılan pencerede üstte general yazar oraya tıkla ve tekrardan sayfayı seç. Seçimi yaptıktan sonra aşağıdaki kodu 2 satırın arasına yapıştır.


CommandButton3.Enabled = True
CommandButton4.Enabled = False

Dim filter As String
Dim caption As String
Dim customerFilename As String
Dim customerWorkbook As Workbook

filter = "Text files (*.xlsm),*.xlsm"

caption = "Lütfen Dosya Seçiniz "
customerFilename = "C:\Users\Ofis1\YandexDisk\SEVKIYAT\GUNLUK.xlsm"
Set customerWorkbook = Application.Workbooks.Open(customerFilename)
Application.ScreenUpdating = False
Application.DisplayAlerts = False


For i = 6 To 38

sat = customerWorkbook.Worksheets(1).Cells(65536, "B").End(xlUp).Row

If ThisWorkbook.Worksheets(1).Range("E" & i).Value <> 0 Then
customerWorkbook.Worksheets(1).Range("A" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("A3").Value
customerWorkbook.Worksheets(1).Range("B" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("B3").Value
customerWorkbook.Worksheets(1).Range("D" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("D3").Value
customerWorkbook.Worksheets(1).Range("P" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("A41").Value
customerWorkbook.Worksheets(1).Range("Q" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("C41").Value
customerWorkbook.Worksheets(1).Range("J" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("D41").Value
customerWorkbook.Worksheets(1).Range("K" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("E41").Value
customerWorkbook.Worksheets(1).Range("L" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("F41").Value
customerWorkbook.Worksheets(1).Range("M" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("H41").Value
customerWorkbook.Worksheets(1).Range("S" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("I41").Value
customerWorkbook.Worksheets(1).Range("T" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("B44").Value
customerWorkbook.Worksheets(1).Range("N" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("C47").Value
customerWorkbook.Worksheets(1).Range("R" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("M2").Value
customerWorkbook.Worksheets(1).Range("O" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("D56").Value

customerWorkbook.Worksheets(1).Range("F" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("E" & i).Value
customerWorkbook.Worksheets(1).Range("H" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("H" & i).Value
customerWorkbook.Worksheets(1).Range("I" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("I" & i).Value
customerWorkbook.Worksheets(1).Range("G" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("B" & i).Value
End If

Next i

customerWorkbook.Save
customerWorkbook.Close
MsgBox "Import İşlemi Başarıyla Tamamlandı!" & Alt _
 
Jr.Developer' Alıntı:
Kodun aşağıdaki kısmını kopyala. ondan sonra geliştirici sekmesinden Visual Basic e tıkla açılan pencerede solda sayfların listesi bulunur.
Hangi sayfada kullanmak istiyorsan çift tıkla. Sonrasında açılan pencerede üstte general yazar oraya tıkla ve tekrardan sayfayı seç. Seçimi yaptıktan sonra aşağıdaki kodu 2 satırın arasına yapıştır.


CommandButton3.Enabled = True
CommandButton4.Enabled = False

Dim filter As String
Dim caption As String
Dim customerFilename As String
Dim customerWorkbook As Workbook

filter = "Text files (*.xlsm),*.xlsm"

caption = "Lütfen Dosya Seçiniz "
customerFilename = "C:\Users\Ofis1\YandexDisk\SEVKIYAT\GUNLUK.xlsm"
Set customerWorkbook = Application.Workbooks.Open(customerFilename)
Application.ScreenUpdating = False
Application.DisplayAlerts = False


For i = 6 To 38

sat = customerWorkbook.Worksheets(1).Cells(65536, "B").End(xlUp).Row

If ThisWorkbook.Worksheets(1).Range("E" & i).Value <> 0 Then
customerWorkbook.Worksheets(1).Range("A" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("A3").Value
customerWorkbook.Worksheets(1).Range("B" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("B3").Value
customerWorkbook.Worksheets(1).Range("D" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("D3").Value
customerWorkbook.Worksheets(1).Range("P" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("A41").Value
customerWorkbook.Worksheets(1).Range("Q" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("C41").Value
customerWorkbook.Worksheets(1).Range("J" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("D41").Value
customerWorkbook.Worksheets(1).Range("K" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("E41").Value
customerWorkbook.Worksheets(1).Range("L" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("F41").Value
customerWorkbook.Worksheets(1).Range("M" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("H41").Value
customerWorkbook.Worksheets(1).Range("S" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("I41").Value
customerWorkbook.Worksheets(1).Range("T" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("B44").Value
customerWorkbook.Worksheets(1).Range("N" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("C47").Value
customerWorkbook.Worksheets(1).Range("R" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("M2").Value
customerWorkbook.Worksheets(1).Range("O" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("D56").Value

customerWorkbook.Worksheets(1).Range("F" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("E" & i).Value
customerWorkbook.Worksheets(1).Range("H" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("H" & i).Value
customerWorkbook.Worksheets(1).Range("I" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("I" & i).Value
customerWorkbook.Worksheets(1).Range("G" & sat + 1).Value = ThisWorkbook.Worksheets(1).Range("B" & i).Value
End If

Next i

customerWorkbook.Save
customerWorkbook.Close
MsgBox "Import İşlemi Başarıyla Tamamlandı!" & Alt _
Genişletmek için tıkla ...

merhaba yanlış anlamadıysam diğer sayfalara yine aynı kodu yapıştırmamı istiyorsunuz. ancak zaten şuanda bu kodlar o sayfalarda da mevcut. general bölümünde de sayfalar yok commandbutton lar var. sanırım ona bağlıyacağım.

ama şöyle ki bu kodlar diğer kopyaladığım sayfalara zaten kopyalarken taşındı. burada acaba "customerWorkbook.Worksheets(1).Range " bölümünde 1 yazdığı için mi ilk kopyayı yapıyordur? farklılaştırmak mı gerekiyor bunu çözemedim.

sizin söylediğiniz şekilde eski kodu silerek tekrardan dediğiniz gibi kodu kopyalayarak yaptım ancak yine ilk sayfayı yazdırdı dosyaya.
 
Merhaba.
Bence uzun uzun açıklama/kod vererek soru sormak yerine;
gerçek belgenizin bir kopyasını forumda paylaşırsanız daha hızlı sonuca ulaşırsınız.
.
 
Ömer BARAN' Alıntı:
Merhaba.
Bence uzun uzun açıklama/kod vererek soru sormak yerine;
gerçek belgenizin bir kopyasını forumda paylaşırsanız daha hızlı sonuca ulaşırsınız.
.
Genişletmek için tıkla ...
HAKLISINIZ. eskiden foruma dosya yüklemek için sadece altın üyelik vardı oradan alıştık buna.
http://s7.dosya.tc/server9/8dy5vm/Arac_Yukleme_Formu.zip.html
dosya düzenleme şifresi : 6520
Ekteki dosyada depo giriş çıkış bölümünde solda günlüğe aktar butonuna bastığımızda herşey normal olarak çalışıyor. Ancak; bu sayfayı kopyaladım ve yanlara 5 kopya daha çıkarttım bunlarda günlüğe kaydet butonuna bastığımda yine ilk depo giriş çıkış formundaki verileri aktarıyor aktif sayfadakini aktarmak yerine.

benim istediğim şey hangi kopya üzerinde çalışıyorsam o butona bastığımda o aktif sayfadaki verileri dosyaya aktarsın.
gunluk dosyasını göndermedim aynı isimde bir dosya açarak testini yapabilirsiniz de arkadaşlar. boş bir dosyaya sıradan veri yazdırması yapıyor zaten..
 
Aynı sorun/ihtiyaç için bir'den fazla konu açmamayınız.
Bunun, çözüme ulaşmanızı hızladırmasının mümkün olmadığını ve forum düzeni açısından doğru olmadığını hatırlatmalıyım.

Sorunuza gelince; kopyalama işlemini yapmadan önce;
DEPO GİRİŞ-ÇIKIŞ isimli sayfanın adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin,
açılacak VBA ekranında sağ taraftaki kodlardan Private Sub CommandButton1_Click() isimli
makroda, aşağıda kırmızı renklendirdiğim kısımları ekleyin.
Sayfa kopyalama işlemini ondan sonra yapın.
Rich (BB code): 
Private Sub CommandButton1_Click()
Dim Mutlu As Long, Say As Byte
Dim historyWks, busayfa As Worksheet
Dim historyWb As Workbook

Set busayfa = ThisWorkbook.ActiveSheet
Application.ScreenUpdating = False

Set historyWb = Workbooks.Open("C:\Users\Ofis1\YandexDisk\SEVKIYAT\KAYNAK.xlsm")
Set historyWks = historyWb.Worksheets("KAYNAK")

historyWb.Activate
historyWks.Activate

Mutlu = ActiveSheet.Range("B65536").End(3).Row + 1

ActiveSheet.Cells(Mutlu, "A") = busayfa.TextBox1.Text
ActiveSheet.Cells(Mutlu, "B") = busayfa.extBox2.Text
ActiveSheet.Cells(Mutlu, "C") = busayfa.TextBox3.Text
ActiveSheet.Cells(Mutlu, "D") = busayfa.TextBox4.Text
Me.TextBox1 = Empty
Me.TextBox2 = Empty
Me.TextBox3 = Empty
Me.TextBox4 = Empty
historyWb.Save
historyWb.Close SaveChanges:=True
Application.ScreenUpdating = True
MsgBox "ÜRÜN KAYDI TAMAMLANDI!", vbInformation, "MiRaBiLiS"
End Sub
 
Son düzenleme:
Ömer BARAN' Alıntı:
Aynı sorun/ihtiyaç için bir'den fazla konu açmamayınız.
Bunun, çözüme ulaşmanızı hızladırmasının mümkün olmadığını ve forum düzeni açısından doğru olmadığını hatırlatmalıyım.

Sorunuza gelince; kopyalama işlemini yapmadan önce;
DEPO GİRİŞ-ÇIKIŞ isimli sayfanın adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin,
açılacak VBA ekranında sağ taraftaki kodlardan Private Sub CommandButton1_Click() isimli
makroda, aşağıda kırmızı renklendirdiğim kısımları ekleyin.
Sayfa kopyalama işlemini ondan sonra yapın.
Rich (BB code): 
Private Sub CommandButton1_Click()
Dim Mutlu As Long, Say As Byte
Dim historyWks, busayfa As Worksheet
Dim historyWb As Workbook

Set busayfa = ThisWorkbook.ActiveSheet
Application.ScreenUpdating = False

Set historyWb = Workbooks.Open("C:\Users\Ofis1\YandexDisk\SEVKIYAT\KAYNAK.xlsm")
Set historyWks = historyWb.Worksheets("KAYNAK")

historyWb.Activate
historyWks.Activate

Mutlu = ActiveSheet.Range("B65536").End(3).Row + 1

ActiveSheet.Cells(Mutlu, "A") = busayfa.TextBox1.Text
ActiveSheet.Cells(Mutlu, "B") = busayfa.extBox2.Text
ActiveSheet.Cells(Mutlu, "C") = busayfa.TextBox3.Text
ActiveSheet.Cells(Mutlu, "D") = busayfa.TextBox4.Text
Me.TextBox1 = Empty
Me.TextBox2 = Empty
Me.TextBox3 = Empty
Me.TextBox4 = Empty
historyWb.Save
historyWb.Close SaveChanges:=True
Application.ScreenUpdating = True
MsgBox "ÜRÜN KAYDI TAMAMLANDI!", vbInformation, "MiRaBiLiS"
End Sub
Genişletmek için tıkla ...
Cevabınız için teşekkür ediyorum.
haklısınız uyarınızda yeni başlayanlarda açıp cevap gelmeyince bu bölüme de yazmak istedim ondan oldu. birdaha olmaz sağolun.

ikinci bir olay,
Private Sub CommandButton4_Click()
satırında yine aynı değişiklikleri mi yapmalıyım acaba? benim sorun yaşadığım kod 4.butondakiydi çünkü.

örneklerseniz ben seri kodlara yerleştiririm.

teşekkrüler.
 
Doğal olarak öyle yapmalısınız.
-- Dim... satırındaki eklemeyi yapın,
-- Set busayfa = ..... satırını aynı şekilde araya ekleyin,
-- alt taraftaki ThisWorkbook.Worksheets(1).Range("A3").Value.... gibi satırların tümünü de busayfa.Range("A3").Value gibi değiştirin.
.
 
çok teşekkür ederim kod çalıştı. elinize sağlık çok sağolun.
 
özür dileyerek soruyorum, aynı şekilde diğer kodlara da bunu uygularsam onlarda çalışır vaziyete gelecekmidir yoksa burada busayfa yerine busayfa1 busayfa2 şekilde mi değiştirmeliyim kodları. commandbutton1 ,2 ve 3 için soruyorum.
 
En azından bir deneyin.
Deneme yaparken, verileri kaydetttiğiniz asıl belge yerine aşağıdaki satırlarda başka bir belgenin adını ve yolunu kullanın:
Set historyWb=...
Set historyWks=...
Kanaatim o ki; 1,2 diye numara vermek gerekmez.
 
Ömer BARAN' Alıntı:
En azından bir deneyin.
Deneme yaparken, verileri kaydetttiğiniz asıl belge yerine aşağıdaki satırlarda başka bir belgenin adını ve yolunu kullanın:
Set historyWb=...
Set historyWks=...
Kanaatim o ki; 1,2 diye numara vermek gerekmez.
Genişletmek için tıkla ...
9N0G53.jpg


iki şekilde de denediğimde yani yukarıdaki gibi ve busayfa1 şeklinde
bu hatayı veriyor.
 
Düğmenin bulunduğu sayfada TextBox1 var mıdır?
 
evet mevcuttur. ama şimdi tasarım modunda dikkatimi çekti de formül alanında =KAT("Forms.TextBox.1";"") yazmakta. kodda ise ActiveSheet.Cells(Mutlu, "A") = busayfa.TextBox1.Text şeklinde değiştirmiştik...

bundan bi sorun çıktı sanırım.
 
Öncelikle örnek belge üzerinden gitmek bakımından,
görüntüsünü verdiğiniz kod'un hangi sayfada yer alan düğme olduğunu söyleyin ki benim de kontrol etme şansım olsun değil mi?
Ayrıca foruma eklediğiniz dosyalarda açma/yazma/sayfa parolalarını kaldırarak belgeyi yenilemenizi önermeliyim.
Bu haliyle dosyanızla/konuyla hiç kimse ilgilenmek istemeyecektir.
Parolayı vermenin .ir alemi yok bence.
İlgileninlen tek konu sizinki olmadığına göre, cevabı yazıp belgeyi kapatıyoruz, sonra tekrar parola neydi, sayfa koruması şifresi neydi vs.
niyet böyle olmayabilir ama; destek olmaya çalışanları yıldırmak için özellikle yapılıyormuş gibi görünüyor doğrusu.
.
 
Ömer BARAN' Alıntı:
Öncelikle örnek belge üzerinden gitmek bakımından,
görüntüsünü verdiğiniz kod'un hangi sayfada yer alan düğme olduğunu söyleyin ki benim de kontrol etme şansım olsun değil mi?
Ayrıca foruma eklediğiniz dosyalarda açma/yazma/sayfa parolalarını kaldırarak belgeyi yenilemenizi önermeliyim.
Bu haliyle dosyanızla/konuyla hiç kimse ilgilenmek istemeyecektir.
Parolayı vermenin .ir alemi yok bence.
İlgileninlen tek konu sizinki olmadığına göre, cevabı yazıp belgeyi kapatıyoruz, sonra tekrar parola neydi, sayfa koruması şifresi neydi vs.
niyet böyle olmayabilir ama; destek olmaya çalışanları yıldırmak için özellikle yapılıyormuş gibi görünüyor doğrusu.
.
Genişletmek için tıkla ...

Anladım sizde haklısınız. söyledikleriniz tamamen mantıklı açıkçası bende alelacele bir şeyler yaptığıma böyle eksikliklerim oldu üstat.

görüntüsünü verdiğim kod, depo giriş çıkış formundan kopyaladığım sayfada yeralmaktadır. gerçek depo giriş çıkışta sıkıntı olmuyor. kopyaladığımızda sağ taraftaki ürün tanımlama ve plaka tanımlama alanları da, kopyalanan sayfalarda işgörmez olmuştur. bunun çözümünü arar iken yukarıdaki sorunla karşılaşıyoruz üstat.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst