Makro kod yardımı

O

onder_09

Altın Üye
Katılım
17 Mart 2017
Mesajlar
206
Excel Vers. ve Dili
2016 türkçe
Altın Üyelik Bitiş Tarihi
19-07-2025
Herkese merhaba iyi günler iyi pazarlar

Kod: 
For X = 4 To Son
                If S2.Cells(X, "Q") > 0 Then
                    Satir = S1.Cells(S1.Rows.Count, 2).End(3).Row + 1
                    S1.Cells(Satir, 1) = S2.Cells(X, "C")
                    S1.Cells(Satir, 2) = "SAYIN " & S2.Cells(X, "B") & " TOPLAMDA EKİM AYI DAHİL " & S2.Cells(X, "Q") & " TL BORCUNUZ VARDIR."
                    S1.Cells(Satir, 1).Resize(, 2).Borders.LineStyle = True
                   
                    Metin = Split(S1.Cells(Satir, 2), " ")
                    Ilk = 0
kodun içindeki EKİM yazısını otomatik olarak bulunduğumuz ayı nasıl yazdırabilirim ? yani kasım ayındaysak kasım yazsın
 
muygun

muygun

Özel Üye
Katılım
6 Temmuz 2004
Mesajlar
9,207
Excel Vers. ve Dili
Excel-2003 Türkçe
Merhaba;

buay = UCase(Replace(Replace(Format(Date, "mmmm"), "i", "İ"), "ı", "I"))

şeklinde tanımlayın ve buay değişkenini EKİM alanında kullanın.

İyi çalışmalar.
 
O

onder_09

Altın Üye
Katılım
17 Mart 2017
Mesajlar
206
Excel Vers. ve Dili
2016 türkçe
Altın Üyelik Bitiş Tarihi
19-07-2025
muygun' Alıntı:
Merhaba;

buay = UCase(Replace(Replace(Format(Date, "mmmm"), "i", "İ"), "ı", "I"))

şeklinde tanımlayın ve buay değişkenini EKİM alanında kullanın.

İyi çalışmalar.
Genişletmek için tıkla ...
Kod: 
For X = 4 To Son
                If S2.Cells(X, "Q") > 0 Then
                    Satir = S1.Cells(S1.Rows.Count, 2).End(3).Row + 1
                    S1.Cells(Satir, 1) = S2.Cells(X, "C")
                    S1.Cells(Satir, 2) = "SAYIN " & S2.Cells(X, "B") & " TOPLAMDA buay = UCase(Replace(Replace(Format(Date, "mmmm"), "i", "İ"), "ı", "I"))
 AYI DAHİL " & S2.Cells(X, "Q") & " TL BORCUNUZ VARDIR."
                    S1.Cells(Satir, 1).Resize(, 2).Borders.LineStyle = True
                    
                    Metin = Split(S1.Cells(Satir, 2), " ")
                    Ilk = 0
bu şekilde yaptım ama hata verdi
 
muygun

muygun

Özel Üye
Katılım
6 Temmuz 2004
Mesajlar
9,207
Excel Vers. ve Dili
Excel-2003 Türkçe
Merhaba;
Örnek dosya eklemediğiniz için basit bir makro ile işlem yaptım.
İnceleyin ve kendi dosyanızdaki adreslere uyarlayın.
İyi çalışmalar.
 

Ekli dosyalar

O

onder_09

Altın Üye
Katılım
17 Mart 2017
Mesajlar
206
Excel Vers. ve Dili
2016 türkçe
Altın Üyelik Bitiş Tarihi
19-07-2025
muygun' Alıntı:
Merhaba;
Örnek dosya eklemediğiniz için basit bir makro ile işlem yaptım.
İnceleyin ve kendi dosyanızdaki adreslere uyarlayın.
İyi çalışmalar.
Genişletmek için tıkla ...
zamanında sizin yapmış olduğunuz çalışma. dosyayı eklemem mümkün değil ama kodları ek olarak ekliyorum. Yardımlarınız için şimdiden teşekkürler.

Kod: 
Option Explicit

Sub Analiz()
    Dim S1 As Worksheet, Veri As Range, S2 As Worksheet, Metin As Variant, Ilk As Integer
    Dim Son As Long, X As Long, Y As Integer, Satir As Long, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("BORÇ LİSTESİ")
    
    S1.Range("A:B").Clear
    Son = S1.Cells(S1.Rows.Count, "H").End(3).Row
    
    For Each Veri In S1.Range("H2:H" & Son)
        If Veri.Value <> "" Then
            Set S2 = Sheets(CStr(Veri.Value))
            Satir = S1.Cells(S1.Rows.Count, 1).End(3).Row + 1
            S1.Cells(Satir, 2) = Veri.Value
            S1.Cells(Satir, 2).Font.ColorIndex = Veri.Font.ColorIndex
            S1.Cells(Satir, 2).Font.Bold = True
            S1.Cells(Satir, 1).Resize(, 2).Borders.LineStyle = True
            
            Son = S2.Cells(S2.Rows.Count, 1).End(3).Row - 1
                        
            For X = 4 To Son
                If S2.Cells(X, "Q") > 0 Then
                    Satir = S1.Cells(S1.Rows.Count, 2).End(3).Row + 1
                    S1.Cells(Satir, 1) = S2.Cells(X, "C")
                    S1.Cells(Satir, 2) = "SAYIN " & S2.Cells(X, "B") & " TOPLAMDA EKİM AYI DAHİL " & S2.Cells(X, "Q") & " TL BORCUNUZ VARDIR."
                    S1.Cells(Satir, 1).Resize(, 2).Borders.LineStyle = True
                  
                    Metin = Split(S1.Cells(Satir, 2), " ")
                    Ilk = 0
                    
                    For Y = 0 To UBound(Metin)
                        If IsNumeric(Metin(Y)) Then
                            S1.Cells(Satir, 2).Characters(Ilk, Len(Metin(Y)) + 4).Font.ColorIndex = 3
                            S1.Cells(Satir, 2).Characters(Ilk, Len(Metin(Y)) + 4).Font.Bold = True
                            S1.Cells(Satir, 2).Characters(Ilk, Len(Metin(Y)) + 4).Font.Size = 11
                            Ilk = Ilk + Len(Metin(Y)) + 1
                        Else
                            Ilk = Ilk + Len(Metin(Y)) + 1
                        End If
                    Next
                End If
            Next
        End If
    Next
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
 
muygun

muygun

Özel Üye
Katılım
6 Temmuz 2004
Mesajlar
9,207
Excel Vers. ve Dili
Excel-2003 Türkçe
Merhaba;

Option Explicit

Sub Analiz()
Dim S1 As Worksheet, Veri As Range, S2 As Worksheet, Metin As Variant, Ilk As Integer
Dim Son As Long, X As Long, Y As Integer, Satir As Long, Zaman As Double
Dim buay
Zaman = Timer

Application.ScreenUpdating = False

buay = UCase(Replace(Replace(Format(Date, "mmmm"), "i", "İ"), "ı", "I"))
Set S1 = Sheets("BORÇ LİSTESİ")

S1.Range("A:B").Clear
Son = S1.Cells(S1.Rows.Count, "H").End(3).Row

For Each Veri In S1.Range("H2:H" & Son)
If Veri.Value <> "" Then
Set S2 = Sheets(CStr(Veri.Value))
Satir = S1.Cells(S1.Rows.Count, 1).End(3).Row + 1
S1.Cells(Satir, 2) = Veri.Value
S1.Cells(Satir, 2).Font.ColorIndex = Veri.Font.ColorIndex
S1.Cells(Satir, 2).Font.Bold = True
S1.Cells(Satir, 1).Resize(, 2).Borders.LineStyle = True

Son = S2.Cells(S2.Rows.Count, 1).End(3).Row - 1

For X = 4 To Son
If S2.Cells(X, "Q") > 0 Then
Satir = S1.Cells(S1.Rows.Count, 2).End(3).Row + 1
S1.Cells(Satir, 1) = S2.Cells(X, "C")
S1.Cells(Satir, 2) = "SAYIN " & S2.Cells(X, "B") & " TOPLAMDA " & buay & " AYI DAHİL " & S2.Cells(X, "Q") & " TL BORCUNUZ VARDIR."
S1.Cells(Satir, 1).Resize(, 2).Borders.LineStyle = True

Metin = Split(S1.Cells(Satir, 2), " ")
Ilk = 0

For Y = 0 To UBound(Metin)
If IsNumeric(Metin(Y)) Then
S1.Cells(Satir, 2).Characters(Ilk, Len(Metin(Y)) + 4).Font.ColorIndex = 3
S1.Cells(Satir, 2).Characters(Ilk, Len(Metin(Y)) + 4).Font.Bold = True
S1.Cells(Satir, 2).Characters(Ilk, Len(Metin(Y)) + 4).Font.Size = 11
Ilk = Ilk + Len(Metin(Y)) + 1
Else
Ilk = Ilk + Len(Metin(Y)) + 1
End If


Next
End If
Next
End If
Next

Set S1 = Nothing
Set S2 = Nothing

Application.ScreenUpdating = True

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Bu şekilde deneyin.
Kodların çalışmasında sorun yoksa ay kısmını koyu renkli eklemeler halleder.
İyi çalışmalar.
 
O

onder_09

Altın Üye
Katılım
17 Mart 2017
Mesajlar
206
Excel Vers. ve Dili
2016 türkçe
Altın Üyelik Bitiş Tarihi
19-07-2025
muygun' Alıntı:
Merhaba;

Option Explicit

Sub Analiz()
Dim S1 As Worksheet, Veri As Range, S2 As Worksheet, Metin As Variant, Ilk As Integer
Dim Son As Long, X As Long, Y As Integer, Satir As Long, Zaman As Double
Dim buay
Zaman = Timer

Application.ScreenUpdating = False

buay = UCase(Replace(Replace(Format(Date, "mmmm"), "i", "İ"), "ı", "I"))
Set S1 = Sheets("BORÇ LİSTESİ")

S1.Range("A:B").Clear
Son = S1.Cells(S1.Rows.Count, "H").End(3).Row

For Each Veri In S1.Range("H2:H" & Son)
If Veri.Value <> "" Then
Set S2 = Sheets(CStr(Veri.Value))
Satir = S1.Cells(S1.Rows.Count, 1).End(3).Row + 1
S1.Cells(Satir, 2) = Veri.Value
S1.Cells(Satir, 2).Font.ColorIndex = Veri.Font.ColorIndex
S1.Cells(Satir, 2).Font.Bold = True
S1.Cells(Satir, 1).Resize(, 2).Borders.LineStyle = True

Son = S2.Cells(S2.Rows.Count, 1).End(3).Row - 1

For X = 4 To Son
If S2.Cells(X, "Q") > 0 Then
Satir = S1.Cells(S1.Rows.Count, 2).End(3).Row + 1
S1.Cells(Satir, 1) = S2.Cells(X, "C")
S1.Cells(Satir, 2) = "SAYIN " & S2.Cells(X, "B") & " TOPLAMDA " & buay & " AYI DAHİL " & S2.Cells(X, "Q") & " TL BORCUNUZ VARDIR."
S1.Cells(Satir, 1).Resize(, 2).Borders.LineStyle = True

Metin = Split(S1.Cells(Satir, 2), " ")
Ilk = 0

For Y = 0 To UBound(Metin)
If IsNumeric(Metin(Y)) Then
S1.Cells(Satir, 2).Characters(Ilk, Len(Metin(Y)) + 4).Font.ColorIndex = 3
S1.Cells(Satir, 2).Characters(Ilk, Len(Metin(Y)) + 4).Font.Bold = True
S1.Cells(Satir, 2).Characters(Ilk, Len(Metin(Y)) + 4).Font.Size = 11
Ilk = Ilk + Len(Metin(Y)) + 1
Else
Ilk = Ilk + Len(Metin(Y)) + 1
End If


Next
End If
Next
End If
Next

Set S1 = Nothing
Set S2 = Nothing

Application.ScreenUpdating = True

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Bu şekilde deneyin.
Kodların çalışmasında sorun yoksa ay kısmını koyu renkli eklemeler halleder.
İyi çalışmalar.
Genişletmek için tıkla ...
Hocam ellerinize kollarınıza sağlık süper ötesi çalıştı kod tam istediğim gibi :)
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst