Kritere göre taşı

[ozuberk]

Merhaba Arkadaşlar,

A110000 arasındaki hücrelerin içeriğinde 260 ile başlayan 13 karakter uzunluğundaki sayıları almak mümkün müdür?

Örneğin:
A1 Hücresinde: 2601234567890
A10 Hücresinde: Excel xxxxx 2601234567890
D15 Hücresinde: Deneme xxxx 2601234567890 Excel xxxxx

Teşekkürler, kolay gelsin.

 

[çıtır]

Deneyiniz.

Sub Kritertas()
Dim s1 As Worksheet
Dim s2 As Worksheet
Dim rng As Range
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Range("A2:A" & s2.Cells(65536, "A").End(3).Row).ClearContents
son = s2.Cells(65536, "A").End(3).Row
For Each rng In s1.Range("A1:E10000")
bul1 = InStr(1, rng, "260")
If bul1 >= 1 Then
bos = InStr(bul1, rng, " ")
If bos >= 1 Then
alır = Mid(rng, bul1, bos + 1 - bul1)
s2.Range("A" & s2.Cells(65536, "A").End(3).Row + 1) = alır
s2.Range("A" & s2.Cells(65536, "A").End(3).Row + 1).NumberFormat = "0"
 If WorksheetFunction.IsText(s2.Range("A" & s2.Cells(65536, "A").End(3).Row)) Or Len(s2.Range("A" & s2.Cells(65536, "A").End(3).Row)) <> 13 Then
s2.Range("A" & s2.Cells(65536, "A").End(3).Row) = ""
End If
End If
bul1 = InStr(1, rng, "260")
If bul1 >= 1 Then
bos = InStr(bul1, rng, " ")
If bos = 0 Then
alır = Mid(rng, bul1, Len(rng))
s2.Range("A" & s2.Cells(65536, "A").End(3).Row + 1) = alır
 s2.Range("A" & s2.Cells(65536, "A").End(3).Row + 1).NumberFormat = "0"
 If WorksheetFunction.IsText(s2.Range("A" & s2.Cells(65536, "A").End(3).Row)) Or Len(s2.Range("A" & s2.Cells(65536, "A").End(3).Row)) <> 13 Then
s2.Range("A" & s2.Cells(65536, "A").End(3).Row) = ""
End If
End If
End If
End If
Next
MsgBox "İŞLEM TAMAM", vbInformation, "SONUÇ"
End Sub

 

[ozuberk]

Hocam cevap için teşekkür ederim. Ufak bir sorun var. A10 ve D15 hücre örneklerinde düzgün çalışıyor yalnız A1 hücresindeki verileri almıyor.

 

[çıtır]

Rica ederim.A1 hücresi şartları taşımıyor olabilir.Ben bir sorunla karşılaşmıyorum.