Çözüldü Sayfa2'ye yeni değerler eklendikçe Sayfa1'e çekme

optimo · 15 Eylül 2018

merhaba, sayfa 2'ye yeni semboller eklendikçe bu sembollerin kapanış, açılış, düşük, yüksek değerlerini sayfa 1'deki ilgili sembolün listeye girdiği tarihin ait olduğu satır ve sembolün kendi sütununa eklemesini istiyorum
mesela 7 eylül 2018 tarihinde listeye girmiş olan sembollerin değerlerini otomatik çeksin fakat 8 eylül 2018 tarihinde B sembolü listede olmasın diğerleri olsun ve diğerlerinin değerleri değişsin, bu durumda 8 eylül tarihine ait satırdaki değerlerden sadece B sembolü boş olacak diğerlerinin 8 eylüldeki değerleri eklenecek ve değer değişikliği önceki tarihleri etkilemeyecek, birkaç gündür yapmaya çalışıyorum olmadı, yardımcı olursanız sevirim teşekkürler

örnek çalışma
https://drive.google.com/file/d/1W6nHrmCauOpCBnWet7trtrw2NKqOBgsu/view

Ömer BARAN · 15 Eylül 2018

Merhaba.

Alt taraftan Sayfa2'nin adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin,
açılan VBA ekranında sağdaki boş alana aşağıdaki kod blokunu yapıştırın.
Sayfa2'de listenin sonuna yeni veriler ekleyerek sonucu gözlemleyin.
NOT: -- Belgeyi "MAKRO İÇEREN" türüyle kaydedin.
-- Veri girişi yaparken önce A sütununa veri yazınız.
.

Rich (BB code):

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column > 5 Then Exit Sub
yeni = Cells(Rows.Count, 1).End(3).Row
If Intersect(Target, Range("A" & yeni & ":E" & yeni)) Is Nothing Then Exit Sub
If WorksheetFunction.CountBlank(Range("A" & yeni & ":E" & yeni)) > 0 Then Exit Sub
Set s1 = Sheets("Sayfa1")
tarih = Date
If WorksheetFunction.CountIf(s1.[A:A], tarih) > 0 Then
    tsat = WorksheetFunction.Match(CLng(tarih), s1.[A:A], 0)
Else
    tsat = s1.Cells(Rows.Count, 2).End(3).Row + 1
    s1.Cells(tsat, 1) = tarih
    s1.Cells(tsat, 2) = "Açılış": s1.Cells(tsat + 1, 2) = "Yüksek"
    s1.Cells(tsat + 2, 2) = "Düşük": s1.Cells(tsat + 3, 2) = "Kapanış"
    s1.Range("A" & tsat & ":A" & tsat + 3).Merge
    s1.[A:A].VerticalAlignment = xlCenter
End If
If WorksheetFunction.CountIf(s1.[1:1], Cells(Target.Row, 1)) = 0 Then
    s1sut = s1.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    s1.Cells(1, s1sut) = Cells(Target.Row, 1)
Else
    s1sut = WorksheetFunction.Match(Cells(Target.Row, 1), s1.[1:1], 0)
End If
s1.Cells(tsat, s1sut) = Cells(Target.Row, 3)
s1.Cells(tsat + 1, s1sut) = Cells(Target.Row, 5)
s1.Cells(tsat + 2, s1sut) = Cells(Target.Row, 4)
s1.Cells(tsat + 3, s1sut) = Cells(Target.Row, 2)
s1.[1:1].Font.Bold = True: s1.[1:1].HorizontalAlignment = xlCenter
End Sub

optimo · 16 Eylül 2018

Ömer BARAN' Alıntı:
Merhaba.

Alt taraftan Sayfa2'nin adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin,
açılan VBA ekranında sağdaki boş alana aşağıdaki kod blokunu yapıştırın.
Sayfa2'de listenin sonuna yeni veriler ekleyerek sonucu gözlemleyin.
NOT: -- Belgeyi "MAKRO İÇEREN" türüyle kaydedin.
-- Veri girişi yaparken önce A sütununa veri yazınız.

tam istediğim gibi olmuş çok teşekkür ederim ama ben bunu asıl çalışmama uygulayamadım, şöyleki bende

Sayfa1 yerine Grafik
Sayfa2 yerine İncelenecekler yazıyor

Verileri çekeceğim İncelenecekler sayfasında;
Kapanış L sütununda
Açılış AE sütununda
Düşük AF sütununda
Yüksek AG sütununda

Sembollerin isimleri asıl çalışmamda hisse senedi sembolleri yani örnek çalışmadaki gibi alfabetik gitmiyor bunu algılıyor sanırım öyle mi?

Ömer BARAN · 16 Eylül 2018

Alfabetik bir sıralama, algılama söz konusu değil.

İşte tam da bu nedenle, cevaplarımın altındaki İMZA bölümünde;
soruların, gerçek belgeyle aynı yapıda örnek belge üzerinden sorulması uyarısı yer alıyor.

Örnek belge, gerçek belgeyle aynı yapıda olmayınca, harcanan emek/zaman boşa gitmiş oluyor ve
kodların tek tek yeni duruma göre yazılması, bazı kısımlarının değişmesini gerektiriyor.

Gerek sayfa isimleri, gerekse de bilgilerin yer aldığı gerçek sütunların aynı olduğu bir örnek belge yükleyin.
Uygun olursam yeni duruma göre tekrar bakarım.
.

optimo · 16 Eylül 2018

Ömer BARAN' Alıntı:
Alfabetik bir sıralama, algılama söz konusu değil.

İşte tam da bu nedenle, cevaplarımın altındaki İMZA bölümünde;
soruların, gerçek belgeyle aynı yapıda örnek belge üzerinden sorulması uyarısı yer alıyor.

Örnek belge, gerçek belgeyle aynı yapıda olmayınca, harcanan emek/zaman boşa gitmiş oluyor ve
kodların tek tek yeni duruma göre yazılması, bazı kısımlarının değişmesini gerektiriyor.

Gerek sayfa isimleri, gerekse de bilgilerin yer aldığı gerçek sütunların aynı olduğu bir örnek belge yükleyin.
Uygun olursam yeni duruma göre tekrar bakarım.
.

çok özür diliyorum forumda yeni sayılırım

birebir aynı yapıda örnek çalışma

https://drive.google.com/open?id=1V_1J1x1TwBWnyu6MPyoeduncswUwADxS

Ömer BARAN · 16 Eylül 2018

Alt taraftan "İncelenecekler" isimli sayfanın adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin,
açılan VBA ekranında sağ tarafa aşağıdaki kod blokunu yapıştırın.
(Aynı alanda; varsa, Worksheet_Change kod'unu silin)
Kod, İncelenecekler isimli sayfa A sütununa Grafik isimli sayfa 1'inci satırında olmayan bir sembol yazılmışsa bu sembolü,
Grafik isimli sayfada en sağdaki ilk boş sütuna sembolun adını ve sağa doğru da sırasıyla Açılış, Yüksek, Düşük ve Kapanış başlığını yazar.
Sayısal veriler de; günün tarihi Grafik sayfasında yoksa ilk boş satıra, varsa ilgili tarihin satırına, sembolün sütunlarında ilgili hücrelere yazdırılır.
.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 And Target.Column = 12 And Target.Column = 31 _
        And Target.Column = 32 And Target.Column <> 33 Then Exit Sub
yeni = Cells(Rows.Count, Target.Column).End(3).Row
alan = "A" & yeni & ", L" & yeni & ", AE" & yeni & ", AF" & yeni & ", AG" & yeni
If Intersect(Target, Range(alan)) Is Nothing Then Exit Sub

If Cells(yeni, "A") = "" Or Cells(yeni, "L") = "" Or Cells(yeni, "AE") = "" _
        Or Cells(yeni, "AF") = "" Or Cells(yeni, "AG") = "" Then Exit Sub
Set s1 = Sheets("Grafik")
tarih = Date
s1sut = gr.Cells(1, Columns.Count).End(xlToLeft).Column + 1
If WorksheetFunction.CountIf(gr.[1:1], Cells(Target.Row, 1)) > 0 Then _
    s1sut = WorksheetFunction.Match(Cells(Target.Row, 1), gr.[1:1], 0)

gr.Cells(1, s1sut) = Cells(Target.Row, 1): gr.Cells(1, s1sut).Font.Bold = True
gr.Cells(1, s1sut + 1) = "Açılış": gr.Cells(1, s1sut + 2) = "Yüksek"
gr.Cells(1, s1sut + 3) = "Düşük": gr.Cells(1, s1sut + 4) = "Kapanış"

If WorksheetFunction.CountIf(gr.[A:A], tarih) > 0 Then
    s1sat = WorksheetFunction.Match(CLng(tarih), gr.[A:A], 0)
Else: s1sat = gr.Cells(Rows.Count, 1).End(3).Row + 1
End If

For sut = 1 To s1sut Step 5
    gr.Cells(s1sat, sut) = Date
    If sut = s1sut Then
        gr.Cells(s1sat, sut + 1) = Cells(Target.Row, "AE")
        gr.Cells(s1sat, sut + 2) = Cells(Target.Row, "AG")
        gr.Cells(s1sat, sut + 3) = Cells(Target.Row, "AF")
        gr.Cells(s1sat, sut + 4) = Cells(Target.Row, "L")
    End If
Next
gr.Columns.AutoFit
End Sub

optimo · 16 Eylül 2018

Ömer BARAN' Alıntı:
Alt taraftan "İncelenecekler" isimli sayfanın adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin,
açılan VBA ekranında sağ tarafa aşağıdaki kod blokunu yapıştırın.
(Aynı alanda; varsa, Worksheet_Change kod'unu silin)
Kod, İncelenecekler isimli sayfa A sütununa Grafik isimli sayfa 1'inci satırında olmayan bir sembol yazılmışsa bu sembolü,
Grafik isimli sayfada en sağdaki ilk boş sütuna sembolun adını ve sağa doğru da sırasıyla Açılış, Yüksek, Düşük ve Kapanış başlığını yazar.
Sayısal veriler de; günün tarihi Grafik sayfasında yoksa ilk boş satıra, varsa ilgili tarihin satırına, sembolün sütunlarında ilgili hücrelere yazdırılır.
.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 1 And Target.Column = 12 And Target.Column = 31 _ And Target.Column = 32 And Target.Column <> 33 Then Exit Sub yeni = Cells(Rows.Count, Target.Column).End(3).Row alan = "A" & yeni & ", L" & yeni & ", AE" & yeni & ", AF" & yeni & ", AG" & yeni If Intersect(Target, Range(alan)) Is Nothing Then Exit Sub If Cells(yeni, "A") = "" Or Cells(yeni, "L") = "" Or Cells(yeni, "AE") = "" _ Or Cells(yeni, "AF") = "" Or Cells(yeni, "AG") = "" Then Exit Sub Set s1 = Sheets("Grafik") tarih = Date s1sut = gr.Cells(1, Columns.Count).End(xlToLeft).Column + 1 If WorksheetFunction.CountIf(gr.[1:1], Cells(Target.Row, 1)) > 0 Then _ s1sut = WorksheetFunction.Match(Cells(Target.Row, 1), gr.[1:1], 0) gr.Cells(1, s1sut) = Cells(Target.Row, 1): gr.Cells(1, s1sut).Font.Bold = True gr.Cells(1, s1sut + 1) = "Açılış": gr.Cells(1, s1sut + 2) = "Yüksek" gr.Cells(1, s1sut + 3) = "Düşük": gr.Cells(1, s1sut + 4) = "Kapanış" If WorksheetFunction.CountIf(gr.[A:A], tarih) > 0 Then s1sat = WorksheetFunction.Match(CLng(tarih), gr.[A:A], 0) Else: s1sat = gr.Cells(Rows.Count, 1).End(3).Row + 1 End If For sut = 1 To s1sut Step 5 gr.Cells(s1sat, sut) = Date If sut = s1sut Then gr.Cells(s1sat, sut + 1) = Cells(Target.Row, "AE") gr.Cells(s1sat, sut + 2) = Cells(Target.Row, "AG") gr.Cells(s1sat, sut + 3) = Cells(Target.Row, "AF") gr.Cells(s1sat, sut + 4) = Cells(Target.Row, "L") End If Next gr.Columns.AutoFit End Sub

ben verileri başka sayfadan kopyala yapıştır şeklinde aldığım için öyle denedim ve runtime 424 hatası verdi debug deyince şu satırı sarıya boyadı Ömer bey, tek tek elle yazınca da verileri hata vermedi ama yine olmadı çekmedi grafik sayfasına

s1sut = gr.Cells(1, Columns.Count).End(xlToLeft).Column + 1

Ömer BARAN · 17 Eylül 2018

Verileri listenin en altına ve her bir veri satırını eksiksiz (sırası önemli olmaksızın eksiksiz olarak, sembol ve sayısal değerleri) elle yazarsanız,
son cevabımdaki kod, son örnek belgeye göre sorunsuz çalışır ve istenileni yapar.
Denemeden cevap yazmak gibi bir alışkanlığım yok.

Konu açılış mesajındaki cümleniz verileri tek tek elle yazacağınız izlenimini uyandırdığı için verdiğim kod Worksheet_Change yapısında bir kod oldu. Verdiğim ilk kod cevabıma ilişkin olarak yazdığınız "tam istediğim gibi olmuş" cümlesi de veri giriş yönteminin ELLE olacağını daha net ortaya koydu.
Bu nedenle de gerçek belgenizle aynı yapıda olduğunu belirttiğiniz son örnek belge için de aynı yapıda bir kod cevabı verdim.

-- Önce, örnek belgesiz soru sordunuz.
-- Ardından, gerçek belgeyle ilgisi olmayan bir örnek belge yüklediniz (bu belgede sorunsuz çalışan kod cevabını verdim).
-- Sonra, gerçek belgeyle aynı yapıda olduğunu belirttiğiniz yeni bir örnek belge yüklediniz (bunun için de deneyerek sorunsuz çalıştığını gördüğüm kod cevabını verdim).
-- Şimdi ise; verilerin elle satır satır yazılmayacağını, hazır verilerin diğer sayfada dağıtıma tabi tutulacağını söylüyorsunuz.

Eğer, İncelenecekler isimli sayfada hazır olan veya kopyala-yapıştır ile hazır olacak olan veri yığınının,
sembol bazlı olarak ilgili sütunlara dağıtmak istediğinizi belirterek soru sorsaydınız
(Kaldı ki; bu durumda da İncelenecekler isimli sayfada, hazır verilerin listeye giriş tarihinin de hazır olması gerekmez miydi?
Yoksa hergün verileri sayfaya aktarıp, bir düğmeye tıklayarak, o günün tarihiyle ilgili sütunlara dağıtarak bir arşiv mi elde etmek istiyorsunuz bilemiyorum tabi.)
tek cevap ile ihtiyacınızı karşılayacak kod oluşturulmuş olacaktı.

Soru sormak zor iş vesselam.
.

optimo · 17 Eylül 2018

Ömer BARAN' Alıntı:
.

Listenin en altına elle girerek denedim yine 424 hatası verdi ve debug dediğimde aynı satırı sarıya boyadı. Acaba kurduğum ofiste ek paket vs. kurmam gerekiyordu da kurmadığım için mi böyle hata alıyorum? Günlük olarak verileri boş İncelenecekler sayfasına aktardığımda, o günün tarihiyle ilgili sütunlara dağıtmasını istiyorum. Dediğini gibi bir düğmeye tıklayarak yapılabiliyor mu cidden, öyleyse excel bir derya gerçekten

Günlerce formül ile yapmaya çalışıp yapamadım buradan çözümü olduğunu görünce sevinçten yazdığım şeyin farkında olamadım özür dilerim.

Ömer BARAN · 17 Eylül 2018

Ekteki belgede yer alan açıklamaları okuyunuz, denemeler yapınız.
Ekteki belgeye, fareyle BURAYA tıklayarak da erişebilirsiniz.
.

optimo · 17 Eylül 2018

Ömer BARAN' Alıntı:
Ekteki belgede yer alan açıklamaları okuyunuz, denemeler yapınız.
Ekteki belgeye, fareyle BURAYA tıklayarak da erişebilirsiniz.
.

abi çok teşekkür ederim, size bir teklifim olacak bunu özel mesaj yoluyla ilettim

Ömer BARAN · 17 Eylül 2018

Kolay gelsin.

Çözüldü Sayfa2'ye yeni değerler eklendikçe Sayfa1'e çekme

optimo

Ömer BARAN

Uzman

optimo

Ömer BARAN

Uzman

optimo

Ömer BARAN

Uzman

optimo

Ömer BARAN

Uzman

optimo

Ömer BARAN

Uzman

Ekli dosyalar

optimo

Ömer BARAN

Uzman