• DİKKAT

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

Raporlu olduğu günleri otomatik aktarma

  • Konbuyu başlatan Konbuyu başlatan sserhat
  • Başlangıç tarihi Başlangıç tarihi
S

sserhat

Katılım
24 Ekim 2012
Mesajlar
71
Excel Vers. ve Dili
excel 2019 tr
Merhaba arkadaşlar,


Dosyada kişinin raporlu olduğu günleri otomatik olarak en sağdaki bir hücre içerisine yazsın istiyorum. Yardımcı olabilirseniz çok müteşekkir olacağım. Şimdiden teşekkürler.
 

Ekli dosyalar

Merhaba
Boş bir module kopyalayın ve deneyin.
Kod: 
Option Explicit
Sub günler()
Dim STR As Long, VR As Variant
Dim BUL As Range, SBT As Variant
For STR = 3 To Cells(Rows.Count, "A").End(xlUp).Row
VR = Empty
Set BUL = Range("A" & STR & ":AF" & STR).Find("r", , , xlWhole)
If Not BUL Is Nothing Then
SBT = BUL.Address
Do
If VR = Empty Then
VR = Day(Cells(2, BUL.Column))
Else
VR = VR & "-" & Day(Cells(2, BUL.Column))
End If
Set BUL = Range("A" & STR & ":AF" & STR).FindNext(BUL)
Loop While Not BUL Is Nothing And BUL.Address <> SBT
End If
Cells(STR, "AI") = VR
Next
End Sub
 
Sayın asikral, makroyu ilgili sayfanın kod kısmına aşağıdaki şekilde düzenlersek b3:af200 aralığındaki her değişimde kendiliğinden çalışır değil mi? (Tabi ne kadar kullanışlı olur bilemem)

Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("b3:af200")) Is Nothing Then Exit Sub
Dim STR As Long, VR As Variant
Dim BUL As Range, SBT As Variant
For STR = 3 To Cells(Rows.Count, "A").End(xlUp).Row
VR = Empty
Set BUL = Range("A" & STR & ":AF" & STR).Find("r", , , xlWhole)
If Not BUL Is Nothing Then
SBT = BUL.Address
Do
If VR = Empty Then
VR = Day(Cells(2, BUL.Column))
Else
VR = VR & "-" & Day(Cells(2, BUL.Column))
End If
Set BUL = Range("A" & STR & ":AF" & STR).FindNext(BUL)
Loop While Not BUL Is Nothing And BUL.Address <> SBT
End If
Cells(STR, "AI") = VR
Next
End Sub
 
Merhaba
Sizin yazdığınız kod hücre seçiminde çalışır değişiklikte değil. Bunun yerine change olayına yazmanız gerekli.
Kod: 
If Intersect(Target, Range("b3:af200")) Is Nothing Then Exit Sub
Bu satırdan sonra
Kod: 
Application.EnableEvents = False
Bu kodu
Kod: 
Next
Bu satırdan sonra
Kod: 
Application.EnableEvents = True
Bu kodu ekleyin. Deneyin.
Kullanışlı olur mu onu bilemem ama başka bir yöntemle olabilir.
Kod: 
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim BUL As Range, SBT As Variant, VR As Variant
Application.EnableEvents = False
If Intersect(Target, Range("B3:AF200")) Is Nothing Then _
Application.EnableEvents = True: Exit Sub
Set BUL = Range("A" & Target.Row & ":AF" & Target.Row). _
Find("r", , , xlWhole)
If Not BUL Is Nothing Then
SBT = BUL.Address
VR = Empty
Do
If VR = Empty Then
VR = Day(Cells(2, Target.Column))
Else
VR = VR & "-" & Day(Cells(2, Target.Column))
End If
Set BUL = Range("A" & Target.Row & ":AF" & Target.Row).FindNext(BUL)
Loop While Not BUL Is Nothing And BUL.Address <> SBT
End If
Cells(Target.Row, "AI") = VR
Application.EnableEvents = True
End Sub
Bu kodu denerseniz daha farklı ve hızlı çözüm olabilir.
 
VErdiğiniz son kodlar, sadece satırdaki en son günü, toplam R sayısı kadar yazıyor. Örneğin bir satırda 1, 3, 5 ve 7'de R yazıyrorsa sonuç hücresinde 7-7-7-7 olarak görünüyor nedense.
 
Kodu aşağıdaki gibi yapınca B3:AF200 aralığında R yazıldığında makro çalışıyor:
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("b3:af200")) Is Nothing Then Exit Sub
Dim STR As Long, VR As Variant
Dim BUL As Range, SBT As Variant
For STR = 3 To Cells(Rows.Count, "A").End(xlUp).Row
VR = Empty
Set BUL = Range("A" & STR & ":AF" & STR).Find("r", , , xlWhole)
If Not BUL Is Nothing Then
SBT = BUL.Address
Do
If VR = Empty Then
VR = Day(Cells(2, BUL.Column))
Else
VR = VR & "-" & Day(Cells(2, BUL.Column))
End If
Set BUL = Range("A" & STR & ":AF" & STR).FindNext(BUL)
Loop While Not BUL Is Nothing And BUL.Address <> SBT
End If
Cells(STR, "AI") = VR
Next
End Sub

Tabi öncelikle A sütununda ilgili satırın dolu olması gerekiyor. Örneğin A5 hücresi boşsa 5. satırdaki hücrelere yazılan R'leri listelemez.
 
Merhaba
Bu kodu dener misiniz_?
Az önceki kodu deneme şansım olmamıştı ezbere değişiklik yaptım.
Kod: 
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim BUL As Range, SBT As Variant, VR As Variant
Application.EnableEvents = False
If Intersect(Target, Range("B3:AF200")) Is Nothing Then _
Application.EnableEvents = True: Exit Sub
Set BUL = Range("A" & Target.Row & ":AF" & Target.Row). _
Find("r", , , xlWhole)
If Not BUL Is Nothing Then
SBT = BUL.Address
VR = Empty
Do
If VR = Empty Then
VR = Day(Cells(2, BUL.Column))
Else
VR = VR & "-" & Day(Cells(2, BUL.Column))
End If
Set BUL = Range("A" & Target.Row & ":AF" & Target.Row).FindNext(BUL)
Loop While Not BUL Is Nothing And BUL.Address <> SBT
End If
Cells(Target.Row, "AI") = VR
Application.EnableEvents = True
End Sub
 
MErhaba
İyi Çalışmalar
Güzel Bir Çalışma
Emeği GEçenlere
Teşekkür Ederim
Bu Uygulamayı
Bende Kullanmak İstiyorum
Şöyle Bir Şey Yapabilirmiyiz Acaba


izin günü olan ( r ) kodların içinde yazılı
Bu ( r ) yi AH1 Hücresine yazabilirmiyiz
H1 De istenirse Üçretli izin içinde ( Üİ ) Yazılabilsin
Yani Aranan H1 Hücresine Yazılabilsin
Arananı ( H1 ) Yazarsak Bir Çok Seçeneğin
Bu Şekilde Günlerini Çıkarabiliriz.
Şİmdiden Teşekkür Ederim.
 
asr35' Alıntı:
MErhaba
İyi Çalışmalar
Güzel Bir Çalışma
Emeği GEçenlere
Teşekkür Ederim
Bu Uygulamayı
Bende Kullanmak İstiyorum
Şöyle Bir Şey Yapabilirmiyiz Acaba


izin günü olan ( r ) kodların içinde yazılı
Bu ( r ) yi AH1 Hücresine yazabilirmiyiz
H1 De istenirse Üçretli izin içinde ( Üİ ) Yazılabilsin
Yani Aranan H1 Hücresine Yazılabilsin
Arananı ( H1 ) Yazarsak Bir Çok Seçeneğin
Bu Şekilde Günlerini Çıkarabiliriz.
Şİmdiden Teşekkür Ederim.
Genişletmek için tıkla ...

Merhaba
Söylediğiniz yapılamayacakmış gibi durmuyor. Lütfen dosya üzerinde örneklendirerek anlatır mısınız_?
 
Merhaba
İyi Çalışmalar
Sayın asi kral

AH1 De Veri Doğrulama Var
AH1 De Seçeneğe Göre
YAni AH1 De NE Seçilirse Onun Günlerini
Getirmeli
Örnek Teki Gibi.
 
Son düzenleme:
asi_kral' Alıntı:
Merhaba
Bu kodu dener misiniz_?
Az önceki kodu deneme şansım olmamıştı ezbere değişiklik yaptım.
Kod: 
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim BUL As Range, SBT As Variant, VR As Variant
Application.EnableEvents = False
If Intersect(Target, Range("B3:AF200")) Is Nothing Then _
Application.EnableEvents = True: Exit Sub
Set BUL = Range("A" & Target.Row & ":AF" & Target.Row). _
Find("r", , , xlWhole)
If Not BUL Is Nothing Then
SBT = BUL.Address
VR = Empty
Do
If VR = Empty Then
VR = Day(Cells(2, BUL.Column))
Else
VR = VR & "-" & Day(Cells(2, BUL.Column))
End If
Set BUL = Range("A" & Target.Row & ":AF" & Target.Row).FindNext(BUL)
Loop While Not BUL Is Nothing And BUL.Address <> SBT
End If
Cells(Target.Row, "AI") = VR
Application.EnableEvents = True
End Sub
Genişletmek için tıkla ...

Şimdi olmuş, teşekkürler.
 
Bunu yaparız bu basit ama bir fark var siz bunu nasıl tetikleyeceksiniz.
AH1 hücresi değiştiğinde mi_?
B3:AF200 aralığında değişiklik yaptığınızda mı_?
Yoksa Butonla istediğiniz zaman mı_?
 
Sayın
asi kral
Bir Butonla İstendiği Zaman
Uygun Olacaktır
 
asr35' Alıntı:
Sayın
asi kral
Bir Butonla İstendiği Zaman
Uygun Olacaktır
Genişletmek için tıkla ...

Merhaba
Boş bir module kopyalayın ve deneyin.
Kod: 
Option Explicit
Sub günler()
Dim STR As Long, VR As Variant
Dim BUL As Range, SBT As Variant
For STR = 3 To Cells(Rows.Count, "A").End(xlUp).Row
VR = Empty
Set BUL = Range("A" & STR & ":AF" & STR).Find(Range("AH1"), , , xlWhole)
If Not BUL Is Nothing Then
SBT = BUL.Address
Do
If VR = Empty Then
VR = Day(Cells(2, BUL.Column))
Else
VR = VR & "-" & Day(Cells(2, BUL.Column))
End If
Set BUL = Range("A" & STR & ":AF" & STR).FindNext(BUL)
Loop While Not BUL Is Nothing And BUL.Address <> SBT
End If
Cells(STR, "AI") = VR
Next
End Sub
Sonra Butona atarsınız.
 
Sayın
asi kral
Benim İçin
Faydalı Bir Çalışma Odu
Çok Teşekkür Ederim
Allah Razı OLsun
Hakkınızı Helal Edin
İyi Çalışmalar.
 
İlginç bir durum oldu. Son mesajımdan sonra R'yi hücreden almak için uğraşırken makro çalışmaz oldu. Dosyayı kaydetmeden kapatıp eski haline getirmem bile durumu düzeltmedi. Selection hali de Change hali de maalesef işlemedi. Sayfada yaptığım hiç bir değişiklik listelenmiyordu. En son artık Excel'i kapatıp yeniden açtım da düzeldi.
 
YUSUF44' Alıntı:
İlginç bir durum oldu. Son mesajımdan sonra R'yi hücreden almak için uğraşırken makro çalışmaz oldu. Dosyayı kaydetmeden kapatıp eski haline getirmem bile durumu düzeltmedi. Selection hali de Change hali de maalesef işlemedi. Sayfada yaptığım hiç bir değişiklik listelenmiyordu. En son artık Excel'i kapatıp yeniden açtım da düzeldi.
Genişletmek için tıkla ...

Makroyu mu durdurdunuz da bu işlemleri yapmadı.
 
Hepinize çok teşekkür ederim, güzel fikirlerinize hayran kaldım. Hakkınızı helal ediniz üstadlar
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst