T.C veya Vergi No Eşleştirmek

[omeryılmaz]

Kurumumuzca denetlenen işletmelerden bazen İşletmecinin T.C nosu alınmakta bazen Vergi Nosuna göre işlem yapılmaktadır.
Eşleştirme yaparak boş hücreleri İsim T.C. veya İsim V.No ile eşleştirme yaparak boş hücreyi doldurmak



Yardımlarınız için şimdiden şükranlarımı sunuyorum....

 

[omeryılmaz]

Bul ekle

İşletme Sahibine ait T.C. ve Vergi No Kayıt eşleştirmesine ilişkin sorumun daha anlaşılabilir olabilmesi için dosyada güncelleme yaptım.

Yardımlarınız için şimdiden şükranlarımı sunuyorum...

 

[nsertoglu]

Aşağıdaki kod ile TC ve Vergi no eşlemesi yapılabilir; sonra VAR/YOK sayısı için biraz gayret de sizden gelsin..

' ** YENİLENDİ ** 16:55 /
Sub TC_VN_esle()
Dim adr(100)
Sheets("KAYIT").Select
Cells(1, 1).Select
sonK = Selection.End(xlToRight).Column + 1
Cells(1, 1).Select
sonR = Selection.End(xlDown).Row
'Orj. sıra için son kolona No yaz
For r = 2 To sonR
Cells(r, sonK) = r - 1
Next r
'Adı-Soyadı Sıralaması yap
Rng = "A1:" & Cells(sonR, sonK).Address
sk = "F1"
Range(Rng).Select
Selection.Sort Key1:=Range(sk), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

For r = 2 To sonR
adS = Cells(r, "F")
tc = Empty
vn = Empty
x = 1
minR = 9999
maxR = 2
For rr = r To sonR
If adS = Cells(rr, "F") Then
If tc = Empty Then
If Cells(rr, "d") <> Empty Then
tc = Cells(rr, "d")
If rr < minR Then minR = rr
If rr > maxR Then maxR = rr
x = x + 1
End If
End If
If vn = Empty Then
If Cells(rr, "e") <> Empty Then
vn = Cells(rr, "e")
If rr < minR Then minR = rr
If rr > maxR Then maxR = rr
x = x + 1
End If
End If
If tc <> Empty And vn <> Empty Then
'yazma işi
MsgBox minR & " - " & maxR
For xx = minR To maxR
Cells(xx, "D").Select
If Cells(xx, "D") = Empty Then Cells(xx, "D") = tc
If Cells(xx, "e") = Empty Then Cells(xx, "e") = vn
Next xx
End If

End If
Next rr
Next r

Range(Rng).Select
sk = Cells(1, sonK).Address
Selection.Sort Key1:=Range(sk), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
' sıralama verisi silinsin
For r = 2 To sonR
Cells(r, sonK) = ""
Next r

' bundan sonra İhlal VAR/YOK sayma işlemi yapılabilir..
End Sub

 

[omeryılmaz]

Hocam Kod

t.c ------ --- v.no

777 ------ 777 Ömer YILMAZ yaptı

Benim İstediğim
t.c ------ --- v.no
11111111111 --------- 777 Ömer YILMAZ

yapması...

İlginiz için şükranlarımı sunuyorum...

 

[nsertoglu]

Hocam Kod

t.c ------ --- v.no

777 ------ 777 Ömer YILMAZ yaptı

Benim İstediğim
t.c ------ --- v.no
11111111111 --------- 777 Ömer YILMAZ

yapması...

İlginiz için şükranlarımı sunuyorum...

Kod yenilenmiştir; lütfen tekrar deneyiniz..

 

[omeryılmaz]

Elinize yüreğinize sağlık.

Teşekkürler ........