Yıla göre otomatik kod üretme

[ikikan]

Arkadaşlar seneye göre otomatik kod üreten alta da bir formül var bu formülün makro karşılığı yapılabilirmi

"UYG-"&YIL(B3)&" "&ÇOKEĞERSAY(DOLAYLI("B3:B"&SATIR());">="&TARİH(YIL(B3);1;1);DOLAYLI("B3:B"&SATIR());"<="&TARİH(YIL(B3);12;31))

otomatik sayı üreten bir makro var ama bunu da sene değişince 1 den başlatıla bilir mi?

örnek dosya ektedir.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Sat, i As Long

If Intersect(Target, [B:B]) Is Nothing Then Exit Sub
Sat = WorksheetFunction.CountA(Range("B2:B" & Rows.Count)) + 1
        For i = 3 To Sat
            Cells(i, "A").Value = "UYG-2021 " & i - 2
        Next i
End Sub

 

[ikikan]

Konu güncel arkadaşlar

 

[veyselemre]

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, [B:B]) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    Dim idx As Long, yil As Integer, eYil As Integer, cell As Range
    
    For Each cell In Range("B3", Cells(Rows.Count, 2).End(3))
        yil = Year(cell)
        If yil <> eYil Then
            idx = 1
            eYil = yil
        End If
        cell.Offset(0, -1).Value = "UYG-" & yil & " " & idx
        idx = idx + 1
    Next cell

    Application.EnableEvents = True
End Sub

 

[Korhan Ayhan]

Alternatif;

Verim çok dediğiniz için dizi yöntemini kullandım. Hız olarak avantaj sağlayacaktır.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim My_Data As Variant, WF As WorksheetFunction
    Dim Tbl As ListObject, Year_Array As Object
    Dim Old_Calculation As Integer, X As Long
    
    On Error GoTo 10
    
    Set WF = WorksheetFunction
    Set Tbl = ActiveSheet.ListObjects("Tablo2")
    Set Year_Array = VBA.CreateObject("Scripting.Dictionary")

    Old_Calculation = Application.Calculation

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

    Tbl.ListColumns(1).DataBodyRange.ClearContents

    My_Data = Tbl.ListColumns(2).DataBodyRange

    ReDim My_List(1 To UBound(My_Data, 1), 1 To 1)

    For X = LBound(My_Data, 1) To UBound(My_Data, 1)
        If My_Data(X, 1) <> "" Then
            If Not Year_Array.Exists(Year(My_Data(X, 1))) Then
                Year_Array.Add Year(My_Data(X, 1)), 1
                My_List(X, 1) = "UYG-" & Year(My_Data(X, 1)) & " " & 1
            Else
                My_List(X, 1) = "UYG-" & Year(My_Data(X, 1)) & " " & Year_Array.Item(Year(My_Data(X, 1))) + 1
                Year_Array.Item(Year(My_Data(X, 1))) = Year_Array.Item(Year(My_Data(X, 1))) + 1
            End If
        End If
    Next
    
    Range("A3").Resize(UBound(My_Data, 1)) = My_List
    
10  With Application
        .ScreenUpdating = True
        .Calculation = Old_Calculation
        .EnableEvents = True
    End With
    
    Set WF = Nothing
    Set Tbl = Nothing
    Set Year_Array = Nothing
End Sub

 

[ikikan]

Alternatif;

Verim çok dediğiniz için dizi yöntemini kullandım. Hız olarak avantaj sağlayacaktır.

Teşekkürler Korhan Bey hızlı ve düzgün çalışıyor, tek sorun tabloya ilk veri girişinde sıklıkla olmamakla beraber bazen hata veriyor, kuvvetle muhtemel diğer kodlarla çakışıyor ama şimdilik sorun yok..

 

[Korhan Ayhan]

Merhaba,

Kod içinde "Application.EnablaEvents = False" komutu olduğu için hata verdiğinde sıkıntı yaratabileceği için koda küçük eklemeler yaptım. Son halini deneyiniz.

Diğer ilk veri girişinde bende sizin kullandığınız diğer kodlar olmadığı için hata vermiyor. Eğer o kodları içeren bir dosya paylaşırsanız düzeltmeye çalışırım.