• DİKKAT

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

Sayfalar arası şartlı aktarım yapma

D

dayi10

Katılım
26 Mayıs 2011
Mesajlar
129
Excel Vers. ve Dili
2007-2010
Merhaba
sayfalar arası şartlara bağlı aktarım yapmaya çalışıyorum.Dosya ektedir.

Yardımlarınız için teşekkür ederim.
 

Ekli dosyalar

Arkadaşlar kusura bakmayın ama yardımlarınızı bekliyorum. Şimdiden yapacağınız yardımlar için teşekkür ederim.
 
dayi10' Alıntı:
Arkadaşlar kusura bakmayın ama yardımlarınızı bekliyorum. Şimdiden yapacağınız yardımlar için teşekkür ederim.
Genişletmek için tıkla ...

Merhaba.
"Sona Ermişleri Çıkar"mak için aşağıdaki KOD'u kullanabilirsiniz.
Kod: 
Sub SONA_ERMİŞLER()
Dim z As Worksheet: Set z = Sheets("Ziyaret")
Dim s As Worksheet: Set s = Sheets("Sona Ermiş")
Dim i   As Long, a
z.Activate
    Application.ScreenUpdating = False
    For i = 12 To Cells(Rows.Count, "D").End(3).Row
        If Not Cells(i, "N") = "" Then
            a = Split(Cells(i, "N"), " ")
            Cells(i, "N") = DateSerial(Right(a(0), 4), Mid(a(0), 4, 2), Left(a(0), 2))
        End If
        If Not Cells(i, "M") = "" Then
            a = Split(Cells(i, "M"), " ")
            Cells(i, "M") = DateSerial(Right(a(0), 4), Mid(a(0), 4, 2), Left(a(0), 2))
        End If
    Next i
z.AutoFilterMode = False
z.Range("D10:Z" & z.[N65536].End(3).Row).AutoFilter
    If Evaluate("=COUNTIF(N:N,""<""&Y8)") = 0 Then
        MsgBox "Sona Ermiş Ziyaret Yok"
        Exit Sub
    End If
z.Range("N12:N" & z.[D65536].End(3).Row).NumberFormat = "m/d/yyyy"
    alan = "N12:N" & z.[N65536].End(3).Row: z.Range(alan).Select
    z.Range("D10:Z" & z.[N65536].End(3).Row).AutoFilter Field:=11, Criteria1:= _
        "<" & CLng(Range("Y8").Value), Operator:=xlAnd
z.Range("D12:Z" & z.[D65536].End(3).Row).SpecialCells(xlCellTypeVisible).Copy s.Range("A" & s.[M65536].End(3).Row + 1)
z.AutoFilterMode = False
z.Range("D10:Z" & z.[N65536].End(3).Row).AutoFilter
For silsat = z.[D65536].End(3).Row To 12 Step -1
    If z.Cells(silsat, "N") < z.Range("Y8") Then
        z.Rows(silsat & ":" & silsat).Delete Shift:=xlUp
    End If
Next
z.Range("D10").Activate
s.Activate
s.Range("A5:W" & s.[M65536].End(3).Row).Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True: MsgBox "B İ T T İ"
End Sub
 
Son düzenleme:
teşekkür ederim ömer baran. bu işlemi yaparken aktarılan verilerin ise ziyaret sayfasından nasıl kaldırılmasını sağlayabilir. ayrıca başlık kısmınıda temizliyor o neyden kaynaklanıyor olabilir.bu islem her ay tekrarlanacagi için sona ermisler sayfasinda en son veriden sonra yazdirmamiz gerekiyor yani her ay aktarma islemi yapmam gerekiyor birde diğer iki sorum hakkında yardımcı olabilirmisiniz.
 
Son düzenleme:
Merhaba.
Bir önceki cevabımdaki KOD'da değişiklik yaptım, tekrar kontrol ediniz.
 
Ömer BARAN' Alıntı:
Merhaba.
Bir önceki cevabımdaki KOD'da değişiklik yaptım, tekrar kontrol ediniz.
Genişletmek için tıkla ...

teşekkür ederim ömer baran. diğer iki soru hakkında yardımcı olabilirmisiniz.
Devam edenden ziyaret sayfasına aktarma yapmayı ve grupları oluşturma hakkında yardımcı olursanız sevinirim. şimdiden teşekkür ederim.
 
Merhaba.
DEVAM EDENLERİ AKTARmak için aşağıdaki KOD'u kullanabilirsiniz.
Grup sayfalarına aktarma ile ilgili olarak; Ziyaret adlı sayfanın Y ve Z sütunundaki ay adlarının oluşumunu anlamadığım için destek veremiyorum, bunu açıklarsanız, o konuya da daha sonra bakarım.
Kod: 
[B]Sub DEVAM_EDENLERİ_AKTAR()[/B]
Dim z As Worksheet: Set z = Sheets("Ziyaret")
Dim d As Worksheet: Set d = Sheets("Devam Eden")
Dim i   As Long, a
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
z.Range("C10:Z" & z.[G65536].End(3).Row).Borders.LineStyle = xlNone
d.Activate
    For satır = 8 To Cells(Rows.Count, "D").End(3).Row
        If Not Cells(satır, "N") = "" Then
            a = Split(Cells(satır, "N"), " ")
            Cells(satır, "N") = DateSerial(Right(a(0), 4), Mid(a(0), 4, 2), Left(a(0), 2))
        End If
        If Not Cells(satır, "M") = "" Then
            a = Split(Cells(satır, "M"), " ")
            Cells(satır, "M") = DateSerial(Right(a(0), 4), Mid(a(0), 4, 2), Left(a(0), 2))
        End If
    Next satır
satır = 0
For satır = 8 To d.[A65536].End(3).Row
    If WorksheetFunction.CountIf(z.Range("H12:H" & z.[H65536].End(3).Row), d.Cells(satır, 6) & "") = 0 Then
    sat = z.[G65536].End(3).Row + 1
        z.Range("D" & sat & ":F" & sat).Merge: z.Range("D" & sat) = z.Range("D" & sat - 1) + 1
        z.Cells(sat, "G") = d.Cells(satır, "E"): z.Range("H" & sat & ":I" & sat).Merge
        z.Cells(sat, "H").NumberFormat = "@": z.Cells(sat, "H") = d.Cells(satır, "F")
        z.Cells(sat, "J") = d.Cells(satır, "H"): z.Cells(sat, "K") = d.Cells(satır, "I")
        d.Range("L" & satır & ":U" & satır).Copy z.Range("L" & sat & ":U" & sat)
        z.Range("V" & sat) = z.Range("P" & sat) - z.Range("S" & sat)
        z.Range("W" & sat) = z.Range("Q" & sat) - z.Range("T" & sat)
        z.Range("X" & sat) = z.Range("R" & sat) - z.Range("U" & sat)
        grup = WorksheetFunction.Match(z.Cells(sat, 7), z.Range("A1:A11"), 0)
        z.Cells(sat, 3) = z.Cells(grup, 2)
    End If
Next
d.Activate
For a = d.[D65536].End(3).Row To 8 Step -1
    If WorksheetFunction.CountIf(z.Range("H12:H" & z.[H65536].End(3).Row), d.Cells(a, 6) & "") > 0 Then
        d.Rows(a & ":" & a).Delete Shift:=xlUp
    End If
Next
z.Range("C10:Z" & z.[G65536].End(3).Row).Borders.LineStyle = xlContinuous
z.Activate
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
10: MsgBox "Devam Edenler ZİYARET sayfasına aktarıldı"
[B]End Sub[/B]
 
teşekkür ederim ömer bey

Yalnız

grup = WorksheetFunction.Match(z.Cells(sat, 7), z.Range("A1:A11"), 0) satırında
run-time errror '1004':
WorksheetFunction sınıfının Match özelliği alınamıyor.

hatasını veriyor neden olabilir.

Ayrıca;
Grupları oluşturma işleminde ise şunu yapmak istiyorum.ilk etapta ziyaret-1 sütununda oluşan aylara y12den başlayıp aşağıda kadar olan sütındaki verileri g8 hücresi ile karşılaştırıp eğer eşit değer varsa ve de bu satırın c sütununda 1 rakamı varsa 1. grup, 2 rakamı varsa 2. gruba aktarılmasını istiyorum. bunun akabinde aynı işlemi ziyaret-2 sütunu içinde yapmak istiyorum yani z12 hücresinden başlayıp aşağıda kadar olan sütundaki verileri g8 hücresi ile karşılaştırıp eğer eşit değer varsa ve de bu satırın c sütununda 1 rakamı varsa 1. grup, 2 rakamı varsa 2. gruba aktarılmasını istiyorum. teşekkür ederim yardımlarınızı için.
 
Merhaba, önceki cevabı gönderdikten hemen sonra düzeltme yapmıştım. Anlaşılan siz de düzeltmeden önce kodu kopyalayıp uygulamışsınız. Mevcut kodda öyle bir satır yok, kontrol edip tekrar deneyin.
Şu an bilgisayar başında değilim. Grup olayı için; ziyaret sayfasına devam edenlerden aktarma yapıldığında son iki sütuna (ay adlarının olduğu sütunlar) hangi ay adının yazılacağını nasıl belirliyorsunuz. Son cevap metninde onu sormuştum aslında.
 
Ömer BARAN' Alıntı:
Merhaba, önceki cevabı gönderdikten hemen sonra düzeltme yapmıştım. Anlaşılan siz de düzeltmeden önce kodu kopyalayıp uygulamışsınız. Mevcut kodda öyle bir satır yok, kontrol edip tekrar deneyin.
Şu an bilgisayar başında değilim. Grup olayı için; ziyaret sayfasına devam edenlerden aktarma yapıldığında son iki sütuna (ay adlarının olduğu sütunlar) hangi ay adının yazılacağını nasıl belirliyorsunuz. Son cevap metninde onu sormuştum aslında.
Genişletmek için tıkla ...

Devam edenlerden aktarma yaptıktan sonra muygun arkadaşımızın yardımıyla bitiş tarihine gore ziyaret1 ve ziyaret2 sütununu ayları yazdırma kodları var.
 
dayi10' Alıntı:
Devam edenlerden aktarma yaptıktan sonra muygun arkadaşımızın yardımıyla bitiş tarihine gore ziyaret1 ve ziyaret2 sütununu ayları yazdırma kodları var.
Genişletmek için tıkla ...
Evet, o kodları yeni gördüm (Sayın muygun hazırladığına göre o KOD'da sorun yoktur sanırım).
Aşağıdaki KOD'u GRUPLARI OLUŞTURmak için kullanabilirsiniz.

Ayrıca aktarılan veri ziyaret sayfasından silinmediğine göre;
aynı satırın tekrar aktarılmasını önlemek için aşağıdaki kod'da yer alan kırmızı satırları ekledim.
Bu satırlar aktarılan satırın C sütunundaki Grup Numarasını siliyor. Tekrar aktarılmasının sakıncası yoksa, o satırları silebilirsiniz.
.
Kod: 
[B]Sub GRUPLARI_OLUŞTUR[/B]
Dim z As Worksheet: Set z = Sheets("Ziyaret")
Dim g1 As Worksheet: Set g1 = Sheets("1.Grup")
Dim g2 As Worksheet: Set g2 = Sheets("2.Grup")
For sütun = 25 To 26
For satır = 12 To z.[H65536].End(3).Row
    If z.Cells(satır, sütun) = "" Then GoTo 10
    If z.Cells(satır, sütun) = z.Cells(8, "G") And z.Cells(satır, "C") = 1 Then
    sat1 = g1.[I65536].End(3).Row + 1
        g1.Cells(sat1, 1) = sat1 - 7
        g1.Cells(sat1, 2) = z.Cells(satır, "G"): g1.Cells(sat1, 3) = z.Cells(satır, "H")
        g1.Range("D" & sat1 & ":H" & sat1) = z.Range("J" & satır & ":N" & satır).Value
        g1.Range("I" & sat1 & ":K" & sat1) = z.Range("V" & satır & ":X" & satır).Value
[COLOR="red"]        z.Cells(satır, 3) = ""[/COLOR]
    ElseIf z.Cells(satır, sütun) = z.Cells(8, "G") And z.Cells(satır, "C") = 2 Then
    sat2 = g2.[I65536].End(3).Row + 1
        g2.Cells(sat2, 1) = sat2 - 7
        g2.Cells(sat2, 2) = z.Cells(satır, "G"): g2.Cells(sat2, 3) = z.Cells(satır, "H")
        g2.Range("D" & sat2 & ":H" & sat2) = z.Range("J" & satır & ":N" & satır).Value
        g2.Range("I" & sat2 & ":K" & sat2) = z.Range("V" & satır & ":X" & satır).Value
[COLOR="Red"]        z.Cells(satır, 3) = ""[/COLOR]
    End If
10: Next
Next
MsgBox "GRUP sayfalarına veriler aktarıldı."
[B]End Sub[/B]
NOT: Bir önceki cevabınızda belirttiğiniz hatanın nedeni G sütunundaki ilçe isimlerinden bazılarının,
A1:A11 aralığındakinden farklı yazılmış olması (bazılarında boşluk var, bazılarında yok) .
Bu verilerin G sütunundakilerle aynı olması lazım. Bu işlemi CTRL+H ile tümünü değiştirerek yapabilirsiniz.
 
Son düzenleme:
Merhaba;
Sanırım sorun çözülmüş. Özel mesajınızı yeni görebildiğimden alternatif olsun.
İyi çalışmalar.
 

Ekli dosyalar

Ömer BARAN' Alıntı:
Evet, o kodları yeni gördüm (Sayın muygun hazırladığına göre o KOD'da sorun yoktur sanırım).
Aşağıdaki KOD'u GRUPLARI OLUŞTURmak için kullanabilirsiniz.

Ayrıca aktarılan veri ziyaret sayfasından silinmediğine göre;
aynı satırın tekrar aktarılmasını önlemek için aşağıdaki kod'da yer alan kırmızı satırları ekledim.
Bu satırlar aktarılan satırın C sütunundaki Grup Numarasını siliyor. Tekrar aktarılmasının sakıncası yoksa, o satırları silebilirsiniz.
.
Kod: 
[B]Sub GRUPLARI_OLUŞTUR[/B]
Dim z As Worksheet: Set z = Sheets("Ziyaret")
Dim g1 As Worksheet: Set g1 = Sheets("1.Grup")
Dim g2 As Worksheet: Set g2 = Sheets("2.Grup")
For sütun = 25 To 26
For satır = 12 To z.[H65536].End(3).Row
    If z.Cells(satır, sütun) = "" Then GoTo 10
    If z.Cells(satır, sütun) = z.Cells(8, "G") And z.Cells(satır, "C") = 1 Then
    sat1 = g1.[I65536].End(3).Row + 1
        g1.Cells(sat1, 1) = sat1 - 7
        g1.Cells(sat1, 2) = z.Cells(satır, "G"): g1.Cells(sat1, 3) = z.Cells(satır, "H")
        g1.Range("D" & sat1 & ":H" & sat1) = z.Range("J" & satır & ":N" & satır).Value
        g1.Range("I" & sat1 & ":K" & sat1) = z.Range("V" & satır & ":X" & satır).Value
[COLOR="red"]        z.Cells(satır, 3) = ""[/COLOR]
    ElseIf z.Cells(satır, sütun) = z.Cells(8, "G") And z.Cells(satır, "C") = 2 Then
    sat2 = g2.[I65536].End(3).Row + 1
        g2.Cells(sat2, 1) = sat2 - 7
        g2.Cells(sat2, 2) = z.Cells(satır, "G"): g2.Cells(sat2, 3) = z.Cells(satır, "H")
        g2.Range("D" & sat2 & ":H" & sat2) = z.Range("J" & satır & ":N" & satır).Value
        g2.Range("I" & sat2 & ":K" & sat2) = z.Range("V" & satır & ":X" & satır).Value
[COLOR="Red"]        z.Cells(satır, 3) = ""[/COLOR]
    End If
10: Next
Next
MsgBox "GRUP sayfalarına veriler aktarıldı."
[B]End Sub[/B]
NOT: Bir önceki cevabınızda belirttiğiniz hatanın nedeni G sütunundaki ilçe isimlerinden bazılarının,
A1:A11 aralığındakinden farklı yazılmış olması (bazılarında boşluk var, bazılarında yok) .
Bu verilerin G sütunundakilerle aynı olması lazım. Bu işlemi CTRL+H ile tümünü değiştirerek yapabilirsiniz.
Genişletmek için tıkla ...

G sütunundakileri değiştirdim. A1:A11 aralığındakilerle aynı. ama aynı hatayı veriyor. neden olabilir acaba.

bu arada yardımlarınız için elinize sağlık
 
Teşekkür ederim arkadaşlar ellerinize gözlerinize sağlık.

Son olarak Sıra numaralarını 1,2,3.... şeklinde aşağıda doğru yazılmasını sayfalarda nasıl yapabiliriz.grup1 ve grup2de bu sıralama mevcut diğer sayfalarda da nasıl yapabiliriz.
 
Son düzenleme:
hızınıza yetişemiyorum ömer bey :)
ömer bey devam edenlerden ekleme yaparken anasasayfada şablonu neden bozuluyor acaba?
 
Zaten kodların bir kısmı ana sayfanızda tarih sütunlarındaki verileri
(aslında tarih değil, aynı şey devam edenlerlerde de vardı sanırım) tarihe dönüştürmekle ilgili.
Sanırım verileri başka kaynaktan kopyala yapıştır ile alıyorsunuz.
Belgenin yeni halini gözden geçirip test ediniz.
Ziyaret ve devam edenler sayfasına orijinal verilerinizi yapıştırın ve düğmeleri test edin.

Sorun olursa (biçim, değer vs), dosyayı sorunlu haliyle kaydedip tekrar eklerseniz iyi olur.

Şablon demişken hücre birleştirmeleri orijinal verilerinizden kaynaklanmıyorsa;
mümkün olduğunca hücre birleştirmekten kaçınmanızı önerebilirim.

Sağlıcakla.
 

Ekli dosyalar

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