Sayfalar arasında sadece istenen sütunların diğer sayfaya geçmesi

nazifdural · 22 Şubat 2009

Değerli Hocalarım
Merhabalar,
Benim bir Excel tablom var bu tablo içindeki sayfalar arasında istediğim sütunların diğer sayfalara geçmesini istiyorum.tablomdaki sayfaları incelerseniz,yapmaya çalıştığım açıklamaları göreceksiniz. bu çalışmayı aslında ben bağ yapıştır ile yaptım,fakat tablo çok ağırlaşıyor ve dosyanın boyutuda bir hayli büyüyor.ben de bunun kodla yazıldığında hem boyutunun hemde kullanım açısından daha güzel olacağını düşünüyorum.forumda örnekleri inceleyerek birşeyler yapıyorum fakat her seferinde hüsrana uğruyorum.
Yardımlarınızı bekliyorum.
Örnek Tablom ektedir.

Necdet · 22 Şubat 2009

Merhaba,

Tahsilata aktarırken döviz tutarlarını anlamadım. Fiyat sayfasındaki tutar Euro, ama Tahsilat sayfasındaki değerlerde TL karşılığı sanırım. O yüzden ilgili yeri açıklama olarak bıraktım siz orayı düzenlersiniz. Kırmızı olarak renklendirdiğim yer.

Kod:

Sub AnketFormAktar()
Application.ScreenUpdating = False
Dim i, j, Bas As Long
Set sr = Sheets("REZERVASYON")
Set sa = Sheets("ANKET FORM")
i = sr.[A65536].End(3).Row
j = sa.[B65536].End(3).Row + 1
sr.Range("A3:I" & i).Copy sa.Range("B" & j)
Bas = j - 1
j = sa.[B65536].End(3).Row
If IsNumeric(sa.Range("A" & Bas)) = False Then
    Bas = Bas + 1
    sa.Range("A" & Bas) = 1
End If
sa.Range("A" & Bas & ":A" & j).DataSeries Rowcol:=xlColumns, Step:=1
Application.ScreenUpdating = True
MsgBox "Aktarım Tamamlanmıştır...", vbInformation, "[URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
End Sub

Kod:

Sub TahsilataAktar()
Set sr = Sheets("REZERVASYON")
Set st = Sheets("TAHSİLAT")
Set sf = Sheets("FİYAT TARİFESİ")
Dim i, j As Long
j = st.[C65536].End(3).Row
Application.ScreenUpdating = False
For i = 3 To sr.[A65536].End(3).Row
    j = j + 1
    st.Cells(j, "C") = sr.Cells(i, "B")
    st.Cells(j, "D") = sr.Cells(i, "D")
    st.Cells(j, "E") = sr.Cells(i, "E")
    st.Cells(j, "F") = sr.Cells(i, "G")
    
    Set Bul = sf.[A:A].Find(st.Cells(j, "F"), LookIn:=xlValues)
    If Not Bul Is Nothing Then
        st.Cells(j, "G") = sf.Cells(Bul.Row, "B")
    Else
        st.Cells(j, "G") = 0
    End If
    
    st.Cells(j, "H") = st.Cells(j, "G") '[B][COLOR=red]*[/COLOR][COLOR=red] st.[B3][/COLOR][/B] Çarpılacak Hücreyi Yazınız
    st.Cells(j, "I") = st.Cells(j, "G") '[COLOR=red][B]* st.[B3][/B][/COLOR] Çarpılacak Hücreyi Yazınız
    st.Cells(j, "J") = st.Cells(j, "G") '[B][COLOR=red]* st.[B3][/COLOR][/B] Çarpılacak Hücreyi Yazınız
Next i
Application.ScreenUpdating = True
MsgBox "Tahsilat Sayfasına Aktarım Tamamlanmıştır", vbInformation, "[URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
End Sub

nazifdural · 22 Şubat 2009

Sn Neşet Hocam,
İlk önce ilginiz için,değerli zamanınızı ayırdığınız için çok teşekkür ederim. Tabloya baktım şöyle ki, Rezervasyon sayfasından Tahsilata ve Anket Forma aktarmalarda sadece Rezervasyonda son girilen yada yapılan son değişiklikleri diğer sayfalara aktarmasını istiyorum.Şimdiden çok teşekkürler

nazifdural · 22 Şubat 2009

Birde Hocam Tahsilat bölümünde ben excelcesini yazayım siz kodlamasını yapın.çünkü ben kod yazmayı bilmiyorum. Usd sütunu için G*B3/B4 Gbp sütunu için G*B3/B5 TL sutünu için G*B3

Necdet · 22 Şubat 2009

Neşet kim bilmiyorum.

Keşke sorunuzu sorarken istediğim kaydı aktarsın deseydiniz şimdiye kadar sorununuz çoktan çözülürdü.

Şimdi mantığı değiştirip yeniden yazmak gerek.

Bir ara fırsat bulduğumda bakarım, olmazsa ilgilenen bir arkadaşım mutlaka çıkar.

Tahsilat bölümünündeki döviz tutarları şöyle olmalı.

Kod:

Sub TahsilataAktar()
Set sr = Sheets("REZERVASYON")
Set st = Sheets("TAHSİLAT")
Set sf = Sheets("FİYAT TARİFESİ")
Dim i, j As Long
j = st.[C65536].End(3).Row
Application.ScreenUpdating = False
For i = 3 To sr.[A65536].End(3).Row
    j = j + 1
    st.Cells(j, "C") = sr.Cells(i, "B")
    st.Cells(j, "D") = sr.Cells(i, "D")
    st.Cells(j, "E") = sr.Cells(i, "E")
    st.Cells(j, "F") = sr.Cells(i, "G")
    
    Set Bul = sf.[A:A].Find(st.Cells(j, "F"), LookIn:=xlValues)
    If Not Bul Is Nothing Then
        st.Cells(j, "G") = sf.Cells(Bul.Row, "B")
    Else
        st.Cells(j, "G") = 0
    End If
    
    st.Cells(j, "H") = [B][COLOR=red]Round(st.Cells(j, "G") * (st.[B3] / st.[B4]), 2)
[/COLOR][/B]    st.Cells(j, "I") = [COLOR=red][B]Round(st.Cells(j, "G") * (st.[B3] / st.[B5]), 2)
[/B][/COLOR]    st.Cells(j, "J") =[COLOR=red][B] Round(st.Cells(j, "G") * st.[B3], 2)
[/B][/COLOR]Next i
Application.ScreenUpdating = True
MsgBox "Tahsilat Sayfasına Aktarım Tamamlanmıştır", vbInformation, "[URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
End Sub

nazifdural · 22 Şubat 2009

Hocam İsminizi yanlış yazdığım için özür dilerim.o kadar çok forumun başında bu sorunumla ilgili araştırma yapıyorum ki.. artık gözlerim iflas etti.gecem gündüzüm karıştı.İsminizle ilgili dikkatsizliğim bu yüzdendir.birde diğer sayfaya istediğim kaydı değil.. yeni girilen kayıtların veya değiştirilen kayıtların geçmesiydi.. Burda yapmaya çalıştığım şu.... Rezervasyon bölümüne yapılan bütün girişlerin tahsilat bölümünde tahsilatının takip edilmesi, tahsilat bölümünde durumu sütununa ben cari,nakit,visa yazdığımda otomatik olarak forumda bulduğum bir kod vasıtasıyla bunları süzüp başka klasör içinde cari,nakit,visa diye excel tabloları açıyor.Eğer ki şu andaki duruma göre her aktar dediğimde,o zaman tahsilat sayfasında birsürü mükerrer kayıt olacak.bu durum anket form sayfası içinde aynı..umarım ne yapmaya çalıştığımı anlatabilmişimdir. Şu ana kadar yardım ve destekleriniz için çok çok teşekkür ederim..

janveljan · 23 Şubat 2009

Necdet Beyin kodlarını düzenledim.

Kod:

Sub AnketFormAktar()
Application.ScreenUpdating = False
Dim i, j, Bas As Long
Set sr = Sheets("REZERVASYON")
Set sa = Sheets("ANKET FORM")
i = sr.[A65536].End(3).Row
j = sa.[B65536].End(3).Row + 1
sr.Range("A" & i & ":I" & i).Copy sa.Range("B" & j)
Bas = j - 1
j = sa.[B65536].End(3).Row
If IsNumeric(sa.Range("A" & Bas)) = False Then
    Bas = Bas + 1
    sa.Range("A" & Bas) = 1
End If
sa.Range("A" & Bas & ":A" & j).DataSeries Rowcol:=xlColumns, Step:=1
Application.ScreenUpdating = True
MsgBox "Aktarım Tamamlanmıştır...", vbInformation, "www.excel.web.tr"
End Sub

Kod:

Sub TahsilataAktar()
Set sr = Sheets("REZERVASYON")
Set st = Sheets("TAHSİLAT")
Set sf = Sheets("FİYAT TARİFESİ")
Dim i, j As Long
j = st.[C65536].End(3).Row + 1
i = sr.[A65536].End(3).Row
Application.ScreenUpdating = False
    
    st.Cells(j, "C") = sr.Cells(i, "B")
    st.Cells(j, "D") = sr.Cells(i, "D")
    st.Cells(j, "E") = sr.Cells(i, "E")
    st.Cells(j, "F") = sr.Cells(i, "G")
    
    Set Bul = sf.[A:A].Find(st.Cells(j, "F"), LookIn:=xlValues)
    If Not Bul Is Nothing Then
        st.Cells(j, "G") = sf.Cells(Bul.Row, "B")
    Else
        st.Cells(j, "G") = 0
    End If
    
    st.Cells(j, "H") = Round(st.Cells(j, "G") * (st.[B3] / st.[B4]), 2)
    st.Cells(j, "I") = Round(st.Cells(j, "G") * (st.[B3] / st.[B5]), 2)
    st.Cells(j, "J") = Round(st.Cells(j, "G") * st.[B3], 2)

Application.ScreenUpdating = True
MsgBox "Tahsilat Sayfasına Aktarım Tamamlanmıştır", vbInformation, "www.excel.web.tr"
End Sub

nazifdural · 23 Şubat 2009

Hocam sağolasın hızır a.s. gibi yetiştin imdadıma... allah razı olsun.. hemen şu kodları bir deneyeyim.

nazifdural · 23 Şubat 2009

Yok hocam, malesef istediğim olmamış..hala Rezervasyon sayfasından aktar butonlarına basıldığında her seferinde aynı kayıtları getiriyor..yani mükerrer kayıtlar oluşuyor..

janveljan · 23 Şubat 2009

Mükerrer kayıt getirmesi normal en son kaydı aktarıyor çünkü, sizin istediğiniz gibi olması için birkaç satırlık kontrol deyimi yazılması lazım.

nazifdural · 23 Şubat 2009

Üstat sizsiniz..

hocam.. yani ben açıkçası o dediğinizden anlamadığımdan.. yorumda yapamıyorum.

janveljan · 24 Şubat 2009

Bu şekilde deneyin.

Kod:

Sub AnketFormAktar()
Application.ScreenUpdating = False
Set sr = Sheets("REZERVASYON")
Set sa = Sheets("ANKET FORM")
j = sa.[B65536].End(3).Row + 1
i = sr.[A65536].End(3).Row

For k = 1 To 9
a = a & sr.Cells(i, k)
b = b & sa.Cells(j - 1, k + 1)
Next
If a <> b Then
    For k = 1 To 9
    sa.Cells(j, k + 1) = sr.Cells(i, k)
    Next
    
    Bas = j - 1
    j = sa.[B65536].End(3).Row
    If IsNumeric(sa.Range("A" & Bas)) = False Then
        Bas = Bas + 1
        sa.Range("A" & Bas) = 1
    End If
    sa.Range("A" & Bas & ":A" & j).DataSeries Rowcol:=xlColumns, Step:=1
    MsgBox "Aktarım Tamamlanmıştır...", vbInformation, "www.excel.web.tr"
Else
    MsgBox "Yeni Kayıt Yok", vbInformation, "www.excel.web.tr"
End If
Application.ScreenUpdating = True
End Sub
Sub TahsilataAktar()
Application.ScreenUpdating = False
Set sr = Sheets("REZERVASYON")
Set st = Sheets("TAHSİLAT")
Set sf = Sheets("FİYAT TARİFESİ")
j = st.[C65536].End(3).Row + 1
i = sr.[A65536].End(3).Row
a = sr.Cells(i, "B") & sr.Cells(i, "D") & sr.Cells(i, "E") & sr.Cells(i, "G")
b = st.Cells(j - 1, "C") & st.Cells(j - 1, "D") & st.Cells(j - 1, "E") & st.Cells(j - 1, "F")
If a <> b Then
    st.Cells(j, "C") = sr.Cells(i, "B")
    st.Cells(j, "D") = sr.Cells(i, "D")
    st.Cells(j, "E") = sr.Cells(i, "E")
    st.Cells(j, "F") = sr.Cells(i, "G")
    
    Set Bul = sf.[A:A].Find(st.Cells(j, "F"), LookIn:=xlValues)
    If Not Bul Is Nothing Then
        st.Cells(j, "G") = sf.Cells(Bul.Row, "B")
    Else
        st.Cells(j, "G") = 0
    End If
    
    st.Cells(j, "H") = Round(st.Cells(j, "G") * (st.[B3] / st.[B4]), 2)
    st.Cells(j, "I") = Round(st.Cells(j, "G") * (st.[B3] / st.[B5]), 2)
    st.Cells(j, "J") = Round(st.Cells(j, "G") * st.[B3], 2)
    MsgBox "Tahsilat Sayfasına Aktarım Tamamlanmıştır", vbInformation, "www.excel.web.tr"
Else
    MsgBox "Yeni Kayıt Yok", vbInformation, "www.excel.web.tr"
End If
Application.ScreenUpdating = True
End Sub

Sayfalar arasında sadece istenen sütunların diğer sayfaya geçmesi

nazifdural

Ekli dosyalar

Necdet

Moderatör

Ekli dosyalar

nazifdural

nazifdural

Necdet

Moderatör

nazifdural

janveljan

nazifdural

nazifdural

janveljan

nazifdural

janveljan