- Katılım
- 6 Kasım 2005
- Mesajlar
- 300
- Altın Üyelik Bitiş Tarihi
- 06-09-2023
A Sutunda Yer Alan Kelİmelerden Uygu Olanlari Bulmak İstİyorum..
Dosya Ektedİr....
Dosya Ektedİr....
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub dene()
[b4:n65536].ClearContents
uz = [b1]
If uz <= 0 Then Exit Sub
sat = 3
For x = 1 To [a65536].End(3).Row
al = Trim(Cells(x, 1))
If Len(al) = uz Then
For y = 2 To uz
If Cells(3, y) = "*" Then
For z = y + 1 To uz + 1
If Cells(3, z) = "*" Then
If Mid(al, y - 1, 1) <> Mid(al, z - 1, 1) Then GoTo atla
End If
Next z
End If
Next y
sat = sat + 1
For y = 2 To uz + 1
Cells(sat, y) = Mid(al, y - 1, 1)
Next y
End If
atla:
Next x
End Sub
Sub kelime_ara()
Dim i As Long, k As Integer, deg As String
Sheets("Sayfa1").Select
Application.ScreenUpdating = False
Range("B4:IV65536").ClearContents
sat = 4
For i = 1 To Cells(65536, "A").End(xlUp).Row
deg = Empty
If Len(Cells(i, "A")) = Range("B1").Value Then
For k = 1 To Len(Cells(i, "A"))
Cells(2, k + 1).Value = Mid(Cells(i, "A").Value, k, 1)
Next k
For k = 1 To Len(Cells(i, "A"))
If Cells(3, k + 1).Value = "*" Then
deg = Cells(2, k + 1).Value
Exit For
End If
Next k
For k = 1 To Len(Cells(i, "A"))
If Cells(3, k + 1).Value = "*" Then
If Cells(2, k + 1).Value <> deg Then GoTo atla
End If
Next k
For k = 1 To Len(Cells(i, "A"))
Cells(sat, k + 1).Value = Mid(Cells(i, "A").Value, k, 1)
Next k
sat = sat + 1
atla:
End If
Next i
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı..!!", vbOKOnly + vbInformation, Application.UserName
End Sub