Makro ile seri numaralandırma hakkında

[antitez21]

Arkadaşlar merhaba

Başlangıç sayısının benim belirleyeceğim şekilde parçaların karşılarına gerekli numaraların gelmesi yani-1-2-3-4 gibi birbirin devamı seri olacak şekilde numaralandırılmasını istiyorum. Bu şekilde yüzlerce sütun var ve elle numaralandırmak çok zaman alıyor. Örnekte gerekli açıklamayı yaptım yardımcı olursanız çok memnun olurum.

 

[Muzaffer Ali]

Merhaba.

Sub test()
    Dim Bak As Long
    Dim Numara As Long
    Dim Say As Long
    'Dim BaslangicNumarasi As Long
    
    Numara = InputBox("Lütfen başlangıç numarasını giriniz.")
    
    If Numara = 0 Then
        MsgBox "Başlangıç numarası 0'dan büyük olmalıdır."
        Exit Sub
    End If
    For Bak = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
        If Cells(1, Bak) = "NUMARA" Then
            Say = Cells(Rows.Count, Bak - 1).End(xlUp).Row
            Cells(2, Bak) = Numara
            With Range(Cells(3, Bak).Address & ":" & Cells(Say, Bak).Address)
                .FormulaLocal = "=" & Cells(2, Bak).Address(False, False) & "+1"
                .Value = .Value
            End With
            Numara = Cells(Say, Bak) + 1
        End If
    Next
    MsgBox "Tamamlandı."
End Sub

 

[Necdet]

Merhaba,

Public Sub SeriNoVer()

Dim arr As Variant
Dim lRow As Long
Dim iCol As Integer
Dim seri As Long

arr = Range("A1").CurrentRegion.Value

If Not (UBound(arr, 2) Mod 3) = 0 Then
    MsgBox "Sütun Sayısı Eksik..."
    End
End If

For iCol = 3 To UBound(arr, 2) Step 3
    seri = arr(2, iCol)
    If Not arr(2, iCol) = "" Then
        For lRow = 3 To UBound(arr, 1)
            If arr(lRow, iCol - 1) = "" Then Exit For
            seri = seri + 1
            arr(lRow, iCol) = seri
        Next lRow
    End If
Next iCol

Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
MsgBox "Bitti...."

End Sub

 

[Necdet]

Son günlerde hep geç kalıyorum yaşlılık işte
Alternatif çözüm olsun.

 

[AdemCan]

Merhaba, alternatif.

Sub test()
Dim s1 As Worksheet, sonR As Long, sonS As Long, r As Long, c As Long
On Error GoTo hata
Set s1 = Sayfa1
sonS = s1.Cells(1, Columns.Count).End(1).Column
numara = Application.InputBox("Başlangıç Numarasını Yazınız...", "")

If numara = "" Or numara = False Then Exit Sub
    numara = numara * 1
    
For c = 3 To sonS Step 3
sonR = s1.Cells(Rows.Count, c - 1).End(3).Row
    For r = 2 To sonR
        s1.Cells(r, c) = numara
        numara = numara + 1
    Next r
Next c

MsgBox "İşlem tamamlandı.", vbInformation, ""
Exit Sub

hata:
    MsgBox "Sadece sayı yazınız!", vbExclamation, ""
End Sub

 

[AdemCan]

Ben baya geç kalmışım.

 

[DoğanD]

Bir alternatif de ben iletmek isterim;

Sub Numarala()
Dim bs, i, y, dolu, ss As Integer
ss = Cells(1, Columns.Count).End(1).Column
bs = InputBox("Başlangıç Sayısını Girin", "")
If bs = "" Or Not IsNumeric(bs) Then Exit Sub
For i = 1 To ss
If Cells(1, i) = "NUMARA" Then
dolu = Range(Split(Cells(1, i - 2).Address(1, 1), "$")(1) & Rows.Count).End(xlUp).Row
    For y = 2 To dolu
Cells(y, i) = bs
bs = bs + 1
    Next y
    End If
Next i
End Sub

 

[antitez21]

Üstadlar çok teşekkür ederim. Harika çalışıyor.. Gerçi balık tutmayı hala öğrenemedik ama bu sitenin katkısını tarif edemem.Emeğinize sağlık.

 

[Muzaffer Ali]

Üstadlar çok teşekkür ederim. Harika çalışıyor.. Gerçi balık tutmayı hala öğrenemedik ama bu sitenin katkısını tarif edemem.Emeğinize sağlık.

1- Değişkenleri öğren
2- If, Else yapısını öğren
3- Döngüleri öğren
4- Locals penceresi her zaman açık olsun (View / Locals Window)
5- Kodları F8'e basarak satır satır çalıştır.
6- Makro kaydet kısmını kullanarak kendini geliştirebilirsin.

Balık tutmanı öğrenmeni sağlayacak şeyler bunlar.
Kolay gelsin.

 

[antitez21]

Eyvallah hocam 40 yaşından sonra başladık haliyle iş güçte derken kafa da artık geç alıyor ama deniyorum mesela kodlarınızı inceleyip bazı değerleri değiştirip sonuçlarına bakıyorum ama yukarıda yazdıklarınızı yavaş yavaş öğrenmeye başladım Olmadı siz üstadlara sormaya devam edeceğiz tabi