• DİKKAT

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

Sayfalardan Veri Aktar, Çift tıklama ile

1Al2Ver

1Al2Ver

Katılım
5 Kasım 2007
Mesajlar
4,727
Excel Vers. ve Dili
64 Bit TR - Microsoft Office 365 - Win11 Home
Merhaba,

YGS-1, YGS-2, YGS-6, MF-1, MF-2 ve MF-4 sayfalarında A yada B yada C sütunlarında çift tıklama yapıldığında, tıklanma sırasına göre, seçilenlerin "Mix" sayfasında sıralanmasını arzuluyorum,

Teşekkür ederim.
 

Ekli dosyalar

1Al2Ver' Alıntı:
Merhaba,

YGS-1, YGS-2, YGS-6, MF-1, MF-2 ve MF-4 sayfalarında A yada B yada C sütunlarında çift tıklama yapıldığında, tıklanma sırasına göre, seçilenlerin "Mix" sayfasında sıralanmasını arzuluyorum,

Teşekkür ederim.
Genişletmek için tıkla ...

Kodu yukarıdaki yazdığınız sayfaların kod bölümüne koyunuz.

Kod: 
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim i, sat
 
If Intersect(Target, Range("a:c")) Is Nothing Then Exit Sub
Cancel = True
If Target.Cells = "" Then Exit Sub
sat = Worksheets("Mix").Cells(Rows.Count, "B").End(3).Row + 1
Sheets("Mix").Cells(sat, 1).Value = sat - 2
For i = 2 To 11
Sheets("Mix").Cells(sat, i).Value = Cells([COLOR=red]Target.Row[/COLOR], i).Value
Next i
MsgBox "aktarma yapıldı"
End Sub
 
Yada ThisWorkbook a aşağıdaki kodu koyup dneyiniz.

Kod: 
Option Explicit
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim i, sat
If Intersect(Target, Range("a:c")) Is Nothing Then Exit Sub
If ActiveSheet.Name <> "Puanlar" Then
If ActiveSheet.Name <> "Mix" Then
Cancel = True
If Target.Cells = "" Then Exit Sub
sat = Worksheets("Mix").Cells(Rows.Count, "B").End(3).Row + 1
Sheets("Mix").Cells(sat, 1).Value = sat - 2
For i = 2 To 11
Sheets("Mix").Cells(sat, i).Value = Cells([COLOR=red]Target.Row[/COLOR], i).Value
Next i
MsgBox "aktarma yapıldı"
End If
End If
End Sub
 
Kodun kırmızı yerlerinde hata vardı düzelttim.
 
halit3' Alıntı:
Kodu yukarıdaki yazdığınız sayfaların kod bölümüne koyunuz.

Kod: 
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim i, sat
 
If Intersect(Target, Range("a:c")) Is Nothing Then Exit Sub
Cancel = True
If Target.Cells = "" Then Exit Sub
sat = Worksheets("Mix").Cells(Rows.Count, "B").End(3).Row + 1
Sheets("Mix").Cells(sat, 1).Value = sat - 2
For i = 2 To 11
Sheets("Mix").Cells(sat, i).Value = Cells([COLOR=red]Target.Row[/COLOR], i).Value
Next i
MsgBox "aktarma yapıldı"
End Sub
Genişletmek için tıkla ...

Halit bey merhaba,

Çok teşekkür ederim, elinize sağlık.

Saygılarımla.
 
Veriler, Renkleriyle Gelsin

Merhaba,

Çözüme ilaveten,

YGS-1, YGS-2, YGS-6, MF-1, MF-2 ve MF-4 sayfalarında A yada B yada C sütunlarında çift tıklama yapıldığında, tıklanma sırasına göre, seçilenlerin "Mix" sayfasında, RENKLERİYLE beraber sıralanmasını arzuluyorum,

Teşekkür ederim.

NOT ;Dosya Kaldırıldı, yenisi 10 nolu mesaja eklendi.
 
Son düzenleme:
1Al2Ver' Alıntı:
Merhaba,

Çözüme ilaveten,

YGS-1, YGS-2, YGS-6, MF-1, MF-2 ve MF-4 sayfalarında A yada B yada C sütunlarında çift tıklama yapıldığında, tıklanma sırasına göre, seçilenlerin "Mix" sayfasında, RENKLERİYLE beraber sıralanmasını arzuluyorum,

Teşekkür ederim.
Genişletmek için tıkla ...

Dosyanızdaki koşullu biçimlendirmeleri kaldırırısanız. aşağıdaki kod işinizi görür.

Kod: 
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim i, sat
 
If Intersect(Target, Range("a:c")) Is Nothing Then Exit Sub
Cancel = True
If Target.Cells = "" Then Exit Sub
sat = Worksheets("Mix").Cells(Rows.Count, "B").End(3).Row + 1
Sheets("Mix").Cells(sat, 1).Value = sat - 2
For i = 2 To 11
Sheets("Mix").Cells(sat, i).Value = Cells(Target.Row, i).Value
If Cells(Target.Row, i).Interior.ColorIndex <> xlNone Then
Sheets("Mix").Cells(sat, i).Interior.ColorIndex = Cells(Target.Row, i).Interior.ColorIndex
End If

Next i
MsgBox "aktarma yapıldı"
End Sub
 
Yada kopyala yuapıştır olarakda kullanılabilir.

Kod: 
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim i, sat, say, sayfa
 sayfa = ActiveSheet.Name
If Intersect(Target, Range("a:c")) Is Nothing Then Exit Sub
Cancel = True
If Target.Cells = "" Then Exit Sub
sat = Worksheets("Mix").Cells(Rows.Count, "B").End(3).Row + 1
Sheets("Mix").Cells(sat, 1).Value = sat - 2
Range("B" & Target.Row & ":K" & Target.Row).Copy
Sheets("Mix").Select
Sheets("Mix").Range("B" & sat).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets(sayfa).Select
MsgBox "aktarma yapıldı"
End Sub
 
halit3' Alıntı:
Yada kopyala yuapıştır olarakda kullanılabilir.

Kod: 
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim i, sat, say, sayfa
 sayfa = ActiveSheet.Name
If Intersect(Target, Range("a:c")) Is Nothing Then Exit Sub
Cancel = True
If Target.Cells = "" Then Exit Sub
sat = Worksheets("Mix").Cells(Rows.Count, "B").End(3).Row + 1
Sheets("Mix").Cells(sat, 1).Value = sat - 2
Range("B" & Target.Row & ":K" & Target.Row).Copy
Sheets("Mix").Select
Sheets("Mix").Range("B" & sat).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets(sayfa).Select
MsgBox "aktarma yapıldı"
End Sub
Genişletmek için tıkla ...

Sayın halit3 merhaba,

YGS-1, YGS-2, YGS-6, MF-1, MF-2 ve MF-4 sayfalarında koşullu biçimlendirme mecburen olacak,

Bu kod aktarmayı renkli yapıyor, ancak koşullarda birlikte aktarıldığı için sonuç "Mix" sayfasında hatalı renk alıyor, renkli hücreleri sabit tutarak yani koşulsuz aktarmak mümkün değil ise ;

Ekteki dosyada "Mix" sayfasındaki M3:Q8 aralığına göre "Mix" sayfasında;

E2:E30, G2:G30, H2:H30 ve I2:I30 aralığına koşul yazalım, ben denedim başarılı olamadım,

Koşul, örneğin ; E sütunu için

1.Koşul =EĞER(VE($D3=$M$3:$M$8;$E3>=$N$3:$N$8)) ise E3, Kırmızı Zemin Beyaz font

2.Koşul =EĞER(VE($D3=$M$3:$M$8;$E3<$N$3:$N$8)) ise E3, Yeşil Zemin Siyah font

sonucunu verecek Koşullu Biçimlendirme formülünü rica ediyorum,

Teşekkür ederim.
 

Ekli dosyalar

1Al2Ver' Alıntı:
Sayın halit3 merhaba,

YGS-1, YGS-2, YGS-6, MF-1, MF-2 ve MF-4 sayfalarında koşullu biçimlendirme mecburen olacak,

Bu kod aktarmayı renkli yapıyor, ancak koşullarda birlikte aktarıldığı için sonuç "Mix" sayfasında hatalı renk alıyor, renkli hücreleri sabit tutarak yani koşulsuz aktarmak mümkün değil ise ;

Ekteki dosyada "Mix" sayfasındaki M3:Q8 aralığına göre "Mix" sayfasında;

E2:E30, G2:G30, H2:H30 ve I2:I30 aralığına koşul yazalım, ben denedim başarılı olamadım,

Koşul, örneğin ; E sütunu için

1.Koşul =EĞER(VE($D3=$M$3:$M$8;$E3>=$N$3:$N$8)) ise E3, Kırmızı Zemin Beyaz font

2.Koşul =EĞER(VE($D3=$M$3:$M$8;$E3<$N$3:$N$8)) ise E3, Yeşil Zemin Siyah font

sonucunu verecek Koşullu Biçimlendirme formülünü rica ediyorum,

Teşekkür ederim.
Genişletmek için tıkla ...

Bunu denermisiniz

Kod: 
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim i, sat
If Intersect(Target, Range("a:c")) Is Nothing Then Exit Sub
Cancel = True
If Target.Cells = "" Then Exit Sub
sat = Worksheets("Mix").Cells(Rows.Count, "B").End(3).Row + 1
Sheets("Mix").Cells(sat, 1).Value = sat - 2
For i = 2 To 10
If i = 5 Or i = 7 Or i = 8 Or i = 9 Then
Sheets("Mix").Cells(sat, i).FormatConditions.Delete
Sheets("Mix").Cells(sat, i).FormatConditions.Add Type:=xlExpression, Formula1:="=EĞER(RC4=R3C13:R8C13;RC5>=R3C14:R8C14)"
Sheets("Mix").Cells(sat, i).FormatConditions(1).Font.ColorIndex = 2
Sheets("Mix").Cells(sat, i).FormatConditions(1).Interior.ColorIndex = 3
Sheets("Mix").Cells(sat, i).FormatConditions.Add Type:=xlExpression, Formula1:="=EĞER(RC4=R3C13:R8C13;RC5<R3C14:R8C14)"
Sheets("Mix").Cells(sat, i).FormatConditions(2).Font.ColorIndex = 1
Sheets("Mix").Cells(sat, i).FormatConditions(2).Interior.ColorIndex = 4
Sheets("Mix").Cells(sat, i).Value = Cells(Target.Row, i).Value
Else
Sheets("Mix").Cells(sat, i).Value = Cells(Target.Row, i).Value
End If
Next
MsgBox "aktarma yapıldı"
End Sub
not=kodu sayfanın kod bölümüne koyunuz diğer taraftan ThisWorkbook daki kodlarıda siliniz.
 
halit3' Alıntı:
Bunu denermisiniz

Kod: 
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim i, sat
If Intersect(Target, Range("a:c")) Is Nothing Then Exit Sub
Cancel = True
If Target.Cells = "" Then Exit Sub
sat = Worksheets("Mix").Cells(Rows.Count, "B").End(3).Row + 1
Sheets("Mix").Cells(sat, 1).Value = sat - 2
For i = 2 To 10
If i = 5 Or i = 7 Or i = 8 Or i = 9 Then
Sheets("Mix").Cells(sat, i).FormatConditions.Delete
Sheets("Mix").Cells(sat, i).FormatConditions.Add Type:=xlExpression, Formula1:="=EĞER(RC4=R3C13:R8C13;RC5>=R3C14:R8C14)"
Sheets("Mix").Cells(sat, i).FormatConditions(1).Font.ColorIndex = 2
Sheets("Mix").Cells(sat, i).FormatConditions(1).Interior.ColorIndex = 3
Sheets("Mix").Cells(sat, i).FormatConditions.Add Type:=xlExpression, Formula1:="=EĞER(RC4=R3C13:R8C13;RC5<R3C14:R8C14)"
Sheets("Mix").Cells(sat, i).FormatConditions(2).Font.ColorIndex = 1
Sheets("Mix").Cells(sat, i).FormatConditions(2).Interior.ColorIndex = 4
Sheets("Mix").Cells(sat, i).Value = Cells(Target.Row, i).Value
Else
Sheets("Mix").Cells(sat, i).Value = Cells(Target.Row, i).Value
End If
Next
MsgBox "aktarma yapıldı"
End Sub
not=kodu sayfanın kod bölümüne koyunuz diğer taraftan ThisWorkbook daki kodlarıda siliniz.
Genişletmek için tıkla ...

Sayın halit3 merhaba,

Umarım sizi çok yormuyorumdur, ayrıca da ilginiz için teşekkür ederim,

Yönergeleriniz doğrultusunda ek'li dosyada düzenleme yaptım, ancak ilk 3 satır dışında kod başarılı olamadı,

Yeniden bakmanızı rica ediyorum, teşekkür ederim.
 

Ekli dosyalar

1Al2Ver' Alıntı:
Sayın halit3 merhaba,

Umarım sizi çok yormuyorumdur, ayrıca da ilginiz için teşekkür ederim,

Yönergeleriniz doğrultusunda ek'li dosyada düzenleme yaptım, ancak ilk 3 satır dışında kod başarılı olamadı,

Yeniden bakmanızı rica ediyorum, teşekkür ederim.
Genişletmek için tıkla ...

Mix sayfasındaki koşullu biçimlendirmeleri sil
ve sil komutunu şu şekilde değiştir.

Kod: 
Sub sil()
Sayfa1.[a3:k30].ClearContents
Sayfa1.[a3:k30].Interior.ColorIndex = xlNone
Sayfa1.[a3:k30].Font.ColorIndex = 0
End Sub

sayfaya ait koduda bununla değiştir.

Kod: 
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim i, sat, r, aranan1
If Intersect(Target, Range("a:c")) Is Nothing Then Exit Sub
Cancel = True
If Target.Cells = "" Then Exit Sub
sat = Worksheets("Mix").Cells(Rows.Count, "B").End(3).Row + 1
Sheets("Mix").Cells(sat, 1).Value = sat - 2

For i = 2 To 10
Sheets("Mix").Cells(sat, i).Value = Cells(Target.Row, i).Value
Sheets("Mix").Cells(sat, i).Interior.ColorIndex = xlNone
Sheets("Mix").Cells(sat, i).Font.ColorIndex = 0
Next

aranan1 = Sheets("Mix").Cells(sat, 4).Value
For r = 3 To 8
If aranan1 = Sheets("Mix").Cells(r, 13).Value Then
If Sheets("Mix").Cells(sat, 5).Value > Sheets("Mix").Cells(r, 14).Value Then
Sheets("Mix").Cells(sat, 5).Interior.ColorIndex = 3
Sheets("Mix").Cells(sat, 5).Font.ColorIndex = 2
Else
Sheets("Mix").Cells(sat, 5).Interior.ColorIndex = 4
End If
If Sheets("Mix").Cells(sat, 7).Value > Sheets("Mix").Cells(r, 15).Value Then
Sheets("Mix").Cells(sat, 7).Interior.ColorIndex = 3
Sheets("Mix").Cells(sat, 7).Font.ColorIndex = 2
Else
Sheets("Mix").Cells(sat, 7).Interior.ColorIndex = 4
End If
If Sheets("Mix").Cells(sat, 8).Value > Sheets("Mix").Cells(r, 16).Value Then
Sheets("Mix").Cells(sat, 8).Interior.ColorIndex = 3
Sheets("Mix").Cells(sat, 8).Font.ColorIndex = 2
Else
Sheets("Mix").Cells(sat, 8).Interior.ColorIndex = 4
End If
If Sheets("Mix").Cells(sat, 9).Value > Sheets("Mix").Cells(r, 17).Value Then
Sheets("Mix").Cells(sat, 9).Interior.ColorIndex = 3
Sheets("Mix").Cells(sat, 9).Font.ColorIndex = 2
Else
Sheets("Mix").Cells(sat, 9).Interior.ColorIndex = 4
End If
End If
Next
MsgBox "aktarma yapıldı"
End Sub

Bu uygulama ile koşullu biçimlendirmeden faz geçmiş oluyoruz hücreyi renklendirmiş oluyoruz.
 
Halit bey merhaba,

Bu ramazan gününde sizi epeyi yordum, gerçekten çok teşekkür ederim,

Puanlar ve Mix sayfası dışındaki koşullu biçimlendirmelerden vaz geçemiyoruz, belki koşulu makro ile verebiliriz,

Daha açıkçası şu ; Puanlar sayfasında yer alan sayılar, öğrencinin aldığı puanlar,

YGS-1:MF-4 sayfalarında A3:K25 arası, Üniversite, Yük.Ok. vb.nin 2010 daki puanları,

Anılan sayfalarda koşul ile, öğrencinin aldığı puanlar ile diğerlerini karşılaştırıp, öğrencinin E1 deki puanı, sütundaki puandan yüksek ise zemin rengi yeşil, değil ise kırmızı oluyor, diyelim ki E1=372.066, E3=355.000 bu durumda E3 zemini yeşil oluyor,

Bu durum G,H,I sütunlarında tam tersi oluyor,

Örneğin G1=167 G3=150 ise G3 zemini kırmızı oluyor yani o üniversite en son 150 nciyi almış dolayısı ile 167 kırmızı oluyor,

Biz de bu renklere göre çift tıklayarak "Mix" sayfasında bir tablo oluşturup, tablodaki kırmızı ve yeşillere göre bir karar veriyoruz.

Sonuç ; Bu nedenlerle anılan sayfalarda bu renkler olmalı,

Anlayışınız, sabrınız ve emekleriniz için tekrar teşekkür ederim.
 
Son düzenleme:
1Al2Ver' Alıntı:
Halit bey merhaba,

Bu ramazan gününde sizi epeyi yordum, gerçekten çok teşekkür ederim,

Puanlar ve Mix sayfası dışındaki koşullu biçimlendirmelerden vaz geçemiyoruz, belki koşulu makro ile verebiliriz,

Daha açıkçası şu ; Puanlar sayfasında yer alan sayılar, öğrencinin aldığı puanlar,

YGS-1:MF-4 sayfalarında A3:K25 arası, Üniversite, Yük.Ok. vb.nin 2010 daki puanları,

Anılan sayfalarda koşul ile, öğrencinin aldığı puanlar ile diğerlerini karşılaştırıp, öğrencinin E1 deki puanı, sütundaki puandan yüksek ise zemin rengi yeşil, değil ise kırmızı oluyor, diyelim ki E1=372.066, E3=355.000 bu durumda E3 zemini yeşil oluyor,

Bu durum G,H,I sütunlarında tam tersi oluyor,

Örneğin G1=167 G3=150 ise G3 zemini kırmızı oluyor yani o üniversite en son 150 nciyi almış dolayısı ile 167 kırmızı oluyor,

Biz de bu renklere göre çift tıklayarak "Mix" sayfasında bir tablo oluşturup, tablodaki kırmızı ve yeşillere göre bir karar veriyoruz.

Sonuç ; Bu nedenlerle anılan sayfalarda bu renkler olmalı,

Anlayışınız, sabrınız ve emekleriniz için tekrar teşekkür ederim.
Genişletmek için tıkla ...


Beni yanlış anladınız ben sadece mix sayfasındaki koşulu bicimlendirmeyi iptalini istemiştim ve kodu ona göre yazdım.
 
Halit bey tekrar merhaba,

Mix sayfasındaki koşulları sildim, diğer sayfalardakileri yeniden yükledim, renkleri de (7,8 ve 9 da)

Sheets("Mix").Cells(sat, 7).Interior.ColorIndex = 4
Sheets("Mix").Cells(sat, 7).Font.ColorIndex = 1
Else
Sheets("Mix").Cells(sat, 7).Interior.ColorIndex = 3

şeklinde değiştirdim, şimdilik sorun yok gibi gözükmekte,

Tekrar teşekkür ederim, elinize sağlık,

Saygılarımla.
 
halit3' Alıntı:
Koşullu biçimlendirde bu dosyada çalışıyor.
Genişletmek için tıkla ...

Halit bey merhaba, iyi sabahlar,

Bunu da arşivledim, renklerle ilgili bir iki küçük düzeltme ile son derece güzel çalışıyor, çok teşekkür ederim zahmetleriniz için,

Saygılarımla.
 
1Al2Ver' Alıntı:
Halit bey merhaba, iyi sabahlar,

Bunu da arşivledim, renklerle ilgili bir iki küçük düzeltme ile son derece güzel çalışıyor, çok teşekkür ederim zahmetleriniz için,

Saygılarımla.
Genişletmek için tıkla ...

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