• DİKKAT

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

Boş Olan en Küçük Sayısı yazdırmak

Katılım
16 Ekim 2007
Mesajlar
25
Excel Vers. ve Dili
Offis 2003 Türkçe
Arkadaşlar merhaba bir excel dosyam var bu dosyada bu makroyu kullanıyorum bu kodda sayfa1 ve sayfa2 deki a sütunlarına bakıp ikisindeki en yüksek sayıdan bir fazlasını veriyor. Ben bu kodu şu şekilde değiştirmek istiyorum. yine sayfa1'e ve sayfa2'e a sütunlarına baksın ve boş olan yani olmayan en küçük sayıyı yazsın yok ise bir büyüğünü yazsın. istiyorum yani örnek olarak " sayfa1" in a sütununda 3,4,5,6 var ise ve "sayfa2" de 7,8,9 var ise "sayfa1" de 4. sutuna birsey yazdığım anda a sütununa "1" yazsın bir sonrakinde "2" bir sonrasında "10" yazsın istiyorum bu konuda yardımlarınızı bekliyorum.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim gun As String
Dim son As Integer
On Error Resume Next
If Target = "" Then Exit Sub
If Target.Column = 4 Then
son = WorksheetFunction.Max(Range("A:A"), Sheets("Sayfa2").Range("A:A")) + 1
Cells(Target.Row, 1) = son
ElseIf Target.Column = 21 Or Target.Column = 22 Or Target.Column = 23 _
Or Target.Column = 24 Or Target.Column = 25 Or Target.Column = 26 Then
If (Target) Then
gun = Format(Date, "dddd")
If gun = "Pazartesi" Then
Target.AddComment CStr(Date - 3)
Else
Target.AddComment CStr(Date - 1)
End If
End If
End If
End Sub
 
Merhaba,
Aşağıdaki kodu sayfa1 kod sayfasnına kopyalayın.
Kod:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sh As Worksheet
Dim deg As Range
Dim sira
Dim sat1, sat2 As Long
    Set sh = Sheets(2)
    sat1 = Range("A" & Rows.Count).End(3).Row
    sat2 = sh.Range("A" & Rows.Count).End(3).Row
        On Error Resume Next
            If Target.Column = 4 Then
            If Target = "" Then Exit Sub
            If Target.Row < 2 Then Exit Sub
    Do
        sira = sira + 1
            Set deg = Range("A2:A" & sat1).Find(sira)
        If deg Is Nothing Then
            Set deg = sh.Range("A2:A" & sat2).Find(sira)
        End If
    Loop Until deg Is Nothing
        Range("A" & Target.Row) = sira
    End If
End Sub
 

Ekli dosyalar

Geri
Üst