Ayni iki sehir arasindaki degerleri sayma

[tirimini]

Merhaba bir sorum okacak yardimci olabilirseniz sevinirim.
Tekrar eden Iki sehir arasindaki kalan degerleri saymasini ve hucrelere yazmasini istiyorum
Ornegin:A KOLONUNDA
ANKARA
Istanbul
Izmir
Adana
Bursa
ANKARA
Ordu
Samsun
ANKARA
Balikesir
Aydin
Nazilli
Uşak
Afyon
Antalya
ANKARA
Mersin
Kahramanmaras
Buradaki ornekte goreceginiz uzere
B1 hucresine ANKARA yazdigimda
"C1"Hucresine ilk ANKARA ile 2.ANKARA arasinda yer alan 4 Sehiri sayip "C1" Hucresine 4 yazacak
Sonra
"D1"Hucresine 2.ANKARA ile 3.ANKARA arasinda yer alan 2 sehiri sayip "D1" Hucresine 2 yazacak
Sonra
"E1" Hucresine 3.ANKARA ile 4.ANKARA arasinda yer alan 5 ili sayip "E1"Hucresine 5 yazacak.Eğer bu zor olacak ise
Alternatif olarak;
ANKARA illeri arasindaki en cok araligi olan rakamida yazsa olur.
Iki ANKARA Arasindaki en fazla deger olan "5" Rakamini "F1"Hucresine yazabilir.
Desteginiz ve yardiminiz icin simdiden cok tesekkur ederim.Iyi gunler dilerim.

 

[muhasebeciyiz]

Sub ŞehirFarkHesapla()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long, j As Long
Dim şehir As String
Dim fark As Long
Dim outputColumn As Long

Set ws = ThisWorkbook.Sheets("Sayfa1")

lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
outputColumn = 3 ' Çıktıların yazılacağı sütun

For i = 1 To lastRow
şehir = ws.Cells(i, 1).Value
fark = 0

For j = i + 1 To lastRow
If ws.Cells(j, 1).Value = şehir Then
Exit For
End If
Next j

If j <= lastRow Then
fark = j - i - 1
End If

If fark <> 0 Then
ws.Cells(1, outputColumn).Value = fark
outputColumn = outputColumn + 1
End If
Next i
End Sub

Deneyiniz

 

[tirimini]

Sub ŞehirFarkHesapla()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long, j As Long
Dim şehir As String
Dim fark As Long
Dim outputColumn As Long

Set ws = ThisWorkbook.Sheets("Sayfa1")

lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
outputColumn = 3 ' Çıktıların yazılacağı sütun

For i = 1 To lastRow
şehir = ws.Cells(i, 1).Value
fark = 0

For j = i + 1 To lastRow
If ws.Cells(j, 1).Value = şehir Then
Exit For
End If
Next j

If j <= lastRow Then
fark = j - i - 1
End If

If fark <> 0 Then
ws.Cells(1, outputColumn).Value = fark
outputColumn = outputColumn + 1
End If
Next i
End Sub

Deneyiniz

Tekrar merhaba cevabiniz icin cok tesekkur ederim.Makro yerine formul ile yapmak mumkun mu?

 

[ÖmerBey]

Merhaba,
C1 hücresine aşağıdaki formülü uygulayıp sağa çekerek çoğaltınız.

=KAÇINCI($B$1;KAYDIR($A$1;KAÇINCI($B$1;$A:$A;0)+TOPLA($B1:B1)+SÜTUNSAY($B1:B1)-1;0;100);0)-1

 

[tirimini]

Merhaba,
C1 hücresine aşağıdaki formülü uygulayıp sağa çekerek çoğaltınız.

=KAÇINCI($B$1;KAYDIR($A$1;KAÇINCI($B$1;$A:$A;0)+TOPLA($B1:B1)+SÜTUNSAY($B1:B1)-1;0;100);0)-1

Merhaba
Cevabiniz için cok tesekkur ederim.
Elinize emeginize saglik iyi ki bu forum sitesi kurulmus.Tekrar tesekkur eder iyi gunler dilerim.

 

[ÖmerBey]

Rica ederim,
İyi çalışmalar...