14 numaralı cevapta verdiğim kodu kullanmıyor musunuz?
Orada verdiğim Worksheet_Change kodunda G ve J sütununa yönelik bir Intersect..... kod satırı hiç kullanılmıyor durumda zaten.
Hocam Tekrar Merhaba,
#14 numaralı cevapta verdiğim kodu kullanmıyor musunuz?
Vermiş olduğunuz kod kullanıldı hocam.
#Orada verdiğim Worksheet_Change kodunda G ve J sütununa yönelik bir Intersect..... kod satırı hiç kullanılmıyor durumda zaten.
22 no 'lu mesajımda çıkan hata mesajı diğer kod içerisinde oluştu. Bu konuyla ilgili 24 no'lu cevabınıza istinaden sadece birini değiştirdim ancak yine hatayı alınca diğerini demi, değiştirmek gerekir diye sormuştum.
Kullanılan kodlar aşağıdaki gibidir. Siyah ile işaretlemiş olduklarım kodları söylemiş olduğunuz gibi değiştirdim ancak yine aynı hata mesajını aldım. Sadece G sütunu ve G ve J yi ayn ı anda revize ederekte denedim.
Dosyayı da ayrıca paylaştım hocam.
Saygılarımı sunarım.
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("G2:G" & Rows.Count)) Is Nothing Then GoTo 10
a = Target.Row
Set s1 = Sheets("List Data")
son = s1.Cells(Rows.Count, "G").End(3).Row
If Target = "" Then
Application.EnableEvents = False
Range("A" & a & ":L" & a).ClearContents
Application.EnableEvents = True
ElseIf WorksheetFunction.CountIf(s1.Range("G1:G" & son), Target) > 0 Then
Application.EnableEvents = False
sat = WorksheetFunction.Match(Target, s1.Range("G1:G" & son), 0)
s1.Range("A" & sat & ":L" & sat).Copy: Cells(a, "A").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Target.Select
Application.EnableEvents = True
End If
10:
If Intersect(Target, Range("J2:J" & Rows.Count)) Is Nothing Then Exit Sub
a = Target.Row
Set s1 = Sheets("List Data")
son = s1.Cells(Rows.Count, "J").End(3).Row
If Target = "" Then
Application.EnableEvents = False
Range("A" & a & ":L" & a).ClearContents
Application.EnableEvents = True
ElseIf WorksheetFunction.CountIf(s1.Range("J1:J" & son), Target) > 0 Then
Application.EnableEvents = False
sat = WorksheetFunction.Match(Target, s1.Range("J1:J" & son), 0)
s1.Range("A" & sat & ":L" & sat).Copy: Cells(a, "A").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Target.Select
Application.EnableEvents = True
End If
End Sub
-------------------------------------------------------------------------------------------------------------------------
Private Sub CommandButton1_Click()
Dim soru As String
Set s1 = Sheets("List Data")
For s = 2 To Cells(Rows.Count, 1).End(3).Row
If Cells(s, 7) = Empty And Cells(s, 10) = Empty Then: eksik = eksik + 1: GoTo 10
If Cells(s, 7) <> "" Then hdf = 7
If Cells(s, 10) <> "" Then hdf = 10
eksik = Empty: sut = Array(1, 3, 4, 5, 6, 8, 9, 11, 12, hdf)
For u = 0 To UBound(sut)
If Cells(s, sut(u)) = "" Then: eksik = eksik + 1: Exit For
Next
10: If Not eksik = Empty Then
MsgBox "EKSİK BİLGİLER TAMAMLANMADAN devam edilemez!" & vbLf & _
"Eksiklik olan satır: " & s, vbCritical
Exit Sub
Else
If WorksheetFunction.CountIf(s1.Columns(hdf), Cells(s, hdf)) = 0 Then
say = say + 1: sat = s1.Cells(Rows.Count, 1).End(3).Row + 1
s1.Range("A" & sat & ":N" & sat).Value = Range("A" & s & ":N" & s).Value
End If
End If
Next
yol = ThisWorkbook.Path & "\"
soru = InputBox("Kaydedilecek Dosya Adını Yazın:")
If soru = Empty Then Exit Sub
isim = soru & ".xlsx"
ThisWorkbook.ActiveSheet.Copy
Application.DisplayAlerts = False
ActiveWorkbook.Close True, yol & isim
Application.DisplayAlerts = True
MsgBox IIf(say >= 1, say & " adet kişi listeye eklenerek,", "") & vbLf & _
yol & " dizinine, " & vbLf & isim & vbLf & "isimli belge kaydedildi.", vbInformation
Exit Sub
bitir:
MsgBox "Dosya seçilmediği için işlem sonlandırıldı"
End Sub
