Makro ile şartlı veri yazdırma

Korhan Ayhan · 1 Nisan 2021

Dediğim gibi kodları revize ettim. Son hallerini deneyiniz.

cedi007 · 1 Nisan 2021

#14 ve #17 numaralı kodlarınızdaki revize sonrası istediğim oldu

Öncelikle bu harika oldu.
Ufak bir ayrıntı farkettim, sizinle paylaşıyorum. Eksiklik midir bilemedim, ama şöyle bir durum var.

Makro gayet sağlıklı çalışıyor, ancak Sheet1'de S sütunundaki en son değer boş ise en son değerden öncekileri yazdırmıyor.

-Mesela manuel olarak son hücreye rastgele bir değer girdim. Son değerin üstündeki 4 adet hücre satırının içini de boşalttım. Bu şekilde olunca boşalttığım 4 adet satırı yazdırıyor. Ancak son satır boş olursa yazdırmıyor.

Şunu çıkardım; sanırım dolu olan son satıra göre yazdırma işlemini gerçekleştiriyor.

Var mıdır üstadım buna bir yorumunuz veya çözümünüz.?

Korhan Ayhan · 1 Nisan 2021

#14 ve #17 nolu mesajlarım da ki kodları tekrar revize ettim.

Son değişkenini tüm sayfadaki son satırı dikkate alacak şekilde düzenledim. Sanırım şimdi sorun çıkarmadan kullanabilirsiniz.

cedi007 · 1 Nisan 2021

Korhan Ayhan' Alıntı:
#14 ve #17 nolu mesajlarım da ki kodları tekrar revize ettim.

Son değişkenini tüm sayfadaki son satırı dikkate alacak şekilde düzenledim. Sanırım şimdi sorun çıkarmadan kullanabilirsiniz.

Elinize emeğinize sağlık, işlem başarılı oldu gayet de sağlıklı. Çok teşekkürler @Korhan Ayhan bey.

cedi007 · 18 Nisan 2021

Merhaba,

Konuyla bağlantılı olduğu için aynı başlık altından devam ediyorum.
Ekteki Sheet1 sayfasında , eğer B2 sütunu boş ve F2 sütunu >1 ise B2 sütununa "Tekrarlayan" yazsın, Count<=1 ise "Devam" yazdırsın. Eğer B2 sütunu dolu ise işlem yapmadan devam etsin.

Makro ile bunu yaptırabilir miyiz, ben formül yazıp makro kaydet ile sağlıklı sonuç alamadım.
Teşekkürler.

Korhan Ayhan · 18 Nisan 2021

Deneyiniz.

C++:

Option Explicit

Sub Test()
    Dim S1 As Worksheet, Aranan As Variant, Son As Long
    Dim Alan As Range, Veri As Range, Bul As Variant
  
    Set S1 = Sheets("Sheet1")
  
    Son = S1.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  
    If Son > 1 Then
        On Error Resume Next
        Set Alan = Nothing
        Set Alan = S1.Range("B2:B" & Son).SpecialCells(xlCellTypeBlanks)
        On Error GoTo 0
        If Not Alan Is Nothing Then
            For Each Veri In Alan
                If S1.Cells(Veri.Row, "F") > 1 Then
                    Veri.Value = "Tekrarlayan"
                Else
                    Veri.Value = "Devam"
                End If
            Next
          
            MsgBox "İşleminiz tamamlanmıştır.", vbInformation
        Else
            MsgBox "Boş hücre bulunamadı!", vbExclamation
        End If
    End If

    Set Alan = Nothing
    Set S1 = Nothing
End Sub

cedi007 · 18 Nisan 2021

Korhan Ayhan' Alıntı:

Deneyiniz.

C++:

Option Explicit

Sub Test()
    Dim S1 As Worksheet, Aranan As Variant, Son As Long
    Dim Alan As Range, Veri As Range, Bul As Variant

    Set S1 = Sheets("Sheet1")

    Son = S1.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

    If Son > 1 Then
        On Error Resume Next
        Set Alan = Nothing
        Set Alan = S1.Range("B2:B" & Son).SpecialCells(xlCellTypeBlanks)
        On Error GoTo 0
        If Not Alan Is Nothing Then
            For Each Veri In Alan
                If S1.Cells(Veri.Row, "F") > 1 Then
                    Veri.Value = "Tekrarlayan"
                Else
                    Veri.Value = "Devam"
                End If
            Next
        
            MsgBox "İşleminiz tamamlanmıştır.", vbInformation
        Else
            MsgBox "Boş hücre bulunamadı!", vbExclamation
        End If
    End If

    Set Alan = Nothing
    Set S1 = Nothing
End Sub

Teşekkürler @Korhan Ayhan bey, emeğinize sağlık.
Sizlerin değerli dönüşlerini beklerken uğraştım biraz ve aşağıdaki kod bloğunu oluşturdum. İnceleyebilir misiniz, kodu test ettim ihtiyacı karşılar nitelikte gibi duruyor.
Sizce de kullanıma uygun mudur?

C++:

Sub deneme()

Dim Son As Long, X As Long
Son = Cells(Rows.Count, "B").End(3).Row
For X = 2 To Son
    If Cells(X, 2) = "" And Cells(X, 10) > 1 Then
    Cells(X, 2) = "Yenilenen"
    Else
    Cells(X, 2) = "Devam"
    End If
Next

End Sub

Korhan Ayhan · 18 Nisan 2021

Benim önerim alandaki sadece boş hücrelere odaklanıyor.

Sizin kullandığınız kod ise alandaki bütün hücreleri işleme alıyor ve koşula göre işlem yapıyor.

Arasında ki fark budur.

Satır sayısı çoğaldığında sizin kullanımınız biraz yavaş çalışır. Bunun dışında sorun çıkarmadan çalışacaktır.

cedi007 · 18 Nisan 2021

Selamlar,

Ekte belirtmiş olduğum dosyada, G sütunundaki tarihleri baz alarak A,B,C sütunlarına kaç günlük veri olduğu sayısını ilgili sütunlar için makro ile yazdırmak istiyorum.

Buradaki amaç verilerin yaşını hesaplatmak. 1-3 gün i.in örneğin sayı 80 gibi..

Değerli fikir ve bilgilerinizi rica ederim..

Korhan Ayhan · 18 Nisan 2021

2. satırda ki veri için örnek hesaplama verirseniz makro yazılabilir. Zira ben hesaplama adımını anlamadım.

cedi007 · 18 Nisan 2021

Korhan Ayhan' Alıntı:
2. satırda ki veri için örnek hesaplama verirseniz makro yazılabilir. Zira ben hesaplama adımını anlamadım.

Şöyle açıklayım; 1-3, 3-7, 7 ve sonrası dediklerim günlerin aralığı.
1 <= 3 gün arasında H sütunundaki verileri saydırıp B2 hücresine yazdırmak istiyorum, bunları diğer 3-7 ve >=7 diye belirtmiş olduğum hücrelere de yazdırmak istiyorum.

Formül olarak şunu yaptım örneğin; bugünün tarihinden G sütunundaki tarihi çıkarıp gün farkını "I" sütununa hesaplattırıyorum. "I" sütunundaki verileri de manuel B2 , C2 , D2 sütunlarına yazıyorum.

Makro içerisinde güncel olarak ŞUANKİ tarihi baz alan bir kod ile G sütunundaki tarihi çıkarıp gün farkını bulacak. Gün farkı 1-3 gün aralığındakileri B2'ye, 3-7 gün aralığında olanları C2'ye, 7 gün ve üzeri olanları da D2'ye yazdırmayı istiyorum. Umarım aktarabilmişimdir.

Dosyada ektedir.

Korhan Ayhan · 18 Nisan 2021

Deneyiniz.

C++:

Option Explicit

Sub Test()
    Dim Formul As Variant, Son As Long
    
    Formul = Array("=SUMPRODUCT(((ROUNDUP(NOW()-G2:G1048576,0)>=1)*(ROUNDUP(NOW()-G2:G1048576,0)<=3)))", _
                   "=SUMPRODUCT(((ROUNDUP(NOW()-G2:G1048576,0)>3)*(ROUNDUP(NOW()-G2:G1048576,0)<=7)))", _
                   "=SUMPRODUCT(--(ROUNDUP(NOW()-G2:G1048576,0)>7)*(G2:G1048576<>""""))")
    
    Son = Cells(Rows.Count, "G").End(3).Row
    
    Range("B2") = Evaluate(Replace(Formul(0), 1048576, Son))
    Range("C2") = Evaluate(Replace(Formul(1), 1048576, Son))
    Range("D2") = Evaluate(Replace(Formul(2), 1048576, Son))
End Sub

cedi007 · 19 Nisan 2021

Korhan Ayhan' Alıntı:

Deneyiniz.

C++:

Option Explicit

Sub Test()
    Dim Formul As Variant, Son As Long
   
    Formul = Array("=SUMPRODUCT(((ROUNDUP(NOW()-G2:G1048576,0)>=1)*(ROUNDUP(NOW()-G2:G1048576,0)<=3)))", _
                   "=SUMPRODUCT(((ROUNDUP(NOW()-G2:G1048576,0)>3)*(ROUNDUP(NOW()-G2:G1048576,0)<=7)))", _
                   "=SUMPRODUCT(--(ROUNDUP(NOW()-G2:G1048576,0)>7)*(G2:G1048576<>""""))")
   
    Son = Cells(Rows.Count, "G").End(3).Row
   
    Range("B2") = Evaluate(Replace(Formul(0), 1048576, Son))
    Range("C2") = Evaluate(Replace(Formul(1), 1048576, Son))
    Range("D2") = Evaluate(Replace(Formul(2), 1048576, Son))
End Sub

Gayet sağlıklı ve tam da istediğim gibi çalışıyor kodunuz. Elinize emeğinize sağlık @Korhan Ayhan bey. Uğraştırdım sizi, çok teşekkürler.

cedi007 · 19 Nisan 2021

@Korhan Ayhan bey, vermiş olduğunuz son kod bloğuna kriter ekleme şansımız var mı acaba? Ekte kriter örneğini belirttim.
6 adet kategorim mevcut. H sütundaki sınıf çeşidi için karşısına değerini getirmesini sağlayabilir miyiz ilave olarak.

Korhan Ayhan · 19 Nisan 2021

Uyguladığım çözümde I-J sütunlarını kullanmadım. Bu sebeple bu sütunları gerekmiyorsa silebilirsiniz.

C++:

Sub Test()
    Dim Formul As Variant, Son As Long
    
    Formul = Array("=SUMPRODUCT(((ROUNDUP(NOW()-$G2:$G1048576,0)>=1)*(ROUNDUP(NOW()-$G2:$G1048576,0)<=3))*($H2:$H1048576=N$1))", _
                   "=SUMPRODUCT(((ROUNDUP(NOW()-$G2:$G1048576,0)>3)*(ROUNDUP(NOW()-$G2:$G1048576,0)<=7))*($H2:$H1048576=N$1))", _
                   "=SUMPRODUCT(--(ROUNDUP(NOW()-$G2:$G1048576,0)>7)*($G2:$G1048576<>"""")*($H2:$H1048576=N$1))")
    
    Son = Cells(Rows.Count, "G").End(3).Row
    
    Range("N2:S2") = Replace(Formul(0), 1048576, Son)
    Range("N3:S3") = Replace(Formul(1), 1048576, Son)
    Range("N4:S4") = Replace(Formul(2), 1048576, Son)
    Range("N2:S4").Value = Range("N2:S4").Value
End Sub

cedi007 · 19 Nisan 2021

Korhan Ayhan' Alıntı:

Uyguladığım çözümde I-J sütunlarını kullanmadım. Bu sebeple bu sütunları gerekmiyorsa silebilirsiniz.

C++:

Sub Test()
    Dim Formul As Variant, Son As Long
   
    Formul = Array("=SUMPRODUCT(((ROUNDUP(NOW()-$G2:$G1048576,0)>=1)*(ROUNDUP(NOW()-$G2:$G1048576,0)<=3))*($H2:$H1048576=N$1))", _
                   "=SUMPRODUCT(((ROUNDUP(NOW()-$G2:$G1048576,0)>3)*(ROUNDUP(NOW()-$G2:$G1048576,0)<=7))*($H2:$H1048576=N$1))", _
                   "=SUMPRODUCT(--(ROUNDUP(NOW()-$G2:$G1048576,0)>7)*($G2:$G1048576<>"""")*($H2:$H1048576=N$1))")
   
    Son = Cells(Rows.Count, "G").End(3).Row
   
    Range("N2:S2") = Replace(Formul(0), 1048576, Son)
    Range("N3:S3") = Replace(Formul(1), 1048576, Son)
    Range("N4:S4") = Replace(Formul(2), 1048576, Son)
    Range("N2:S4").Value = Range("N2:S4").Value
End Sub

Gayet sağlıklı ve tam da istediğim gibi çalışıyor. @Korhan Ayhan bey, emeğinize sağlık. Kolaylıklar dilerim.

cedi007 · 5 Haziran 2021

Merhaba,

Konular benzer olduğundan yeni konu açma gereği duymadım.
Ekte belirtmiş olduğum dosya içerisinde detaylıca belirttim.

Özetle; makro ile parça al fonksiyonunu belirli şartlara göre uygulayabilmek istiyorum. Daha önce @Korhan Ayhan bey'in göndermiş olduğu örnek kodlarını kendime göre editleyip bir kaç yerde kullanabildim. Ancak bu sefer olmadı.

Örneğin aşağıdaki kod içinde (i, 5) 'teki hücrede 3131-CDR3032152555 soldan ilk 5 karakteri almak istediğimde - işareti de geliyor haliyle. Tire - işaretini almadan sadece 3131 şeklinde bunu nasıl yazdırabilirim ? Diyeceksiniz ki; Value, 1,4 yapabilirsin, evet ama hücreler tek tip değil o yüzden yapamadım.

Desteklerinizi rica ediyorum.

Kod:

Sub ID_yazdir()
Application.ScreenUpdating = False

    Dim Son As Long, deg, i As Long, durum As Boolean, j As Integer
   
    Son = Cells(Rows.Count, "A").End(xlUp).Row
    deg = Array("*MASA*")
    Application.ScreenUpdating = False
   
    For i = Son To 1 Step -1
        durum = False
        For j = 0 To UBound(deg)
            If Cells(i, "A") Like deg(j) Then durum = True
            If durum = True Then Exit For
        Next j
        If durum = True Then Cells(i, 4) = Mid(Cells(i, 5).Value, 1, 5)
    Next i
   
    Application.ScreenUpdating = True

End Sub

Korhan Ayhan · 6 Haziran 2021

Deneyiniz.

C++:

Option Explicit

Sub ID_YAZ()
    Dim Veri As Range

    For Each Veri In Range("A2:A" & Cells(Rows.Count, 1).End(3).Row)
        If Veri.Offset(, 3) = "" Then Veri.Offset(, 3) = Veri.Offset(, 4)
        Select Case Veri.Value
            Case "MASA"
                If InStr(1, Veri.Offset(, 4), "-") > 0 Then
                    Veri.Offset(, 3) = Split(Veri.Offset(, 4), "-")(0)
                End If
            Case "LAPTOP"
                If InStr(1, Veri.Offset(, 4), "-") > 0 Then
                    Veri.Offset(, 3) = Split(Veri.Offset(, 4), "(")(0)
                End If
        End Select
    Next
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

cedi007 · 6 Haziran 2021

Korhan Ayhan' Alıntı:

Deneyiniz.

C++:

Option Explicit

Sub ID_YAZ()
    Dim Veri As Range

    For Each Veri In Range("A2:A" & Cells(Rows.Count, 1).End(3).Row)
        If Veri.Offset(, 3) = "" Then Veri.Offset(, 3) = Veri.Offset(, 4)
        Select Case Veri.Value
            Case "MASA"
                If InStr(1, Veri.Offset(, 4), "-") > 0 Then
                    Veri.Offset(, 3) = Split(Veri.Offset(, 4), "-")(0)
                End If
            Case "LAPTOP"
                If InStr(1, Veri.Offset(, 4), "-") > 0 Then
                    Veri.Offset(, 3) = Split(Veri.Offset(, 4), "(")(0)
                End If
        End Select
    Next
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Teşekkürler @Korhan Ayhan bey. Sorunsuz çalıştı.

Makro ile şartlı veri yazdırma

Korhan Ayhan

Administrator

cedi007

Korhan Ayhan

Administrator

cedi007

cedi007

Ekli dosyalar

Korhan Ayhan

Administrator

cedi007

Korhan Ayhan

Administrator

cedi007

Ekli dosyalar

Korhan Ayhan

Administrator

cedi007

Ekli dosyalar

Korhan Ayhan

Administrator

cedi007

cedi007

Ekli dosyalar

Korhan Ayhan

Administrator

cedi007

cedi007

Ekli dosyalar

Korhan Ayhan

Administrator

cedi007