İlk 10 karakterleri eşleşen resimleri getirmek

[tahsinanarat]

Private Sub Worksheet_Change(ByVal Target As Range)
 'ActiveSheet.Unprotect
 If Intersect(Target, [h1:h65536]) Is Nothing Then Exit Sub
If Target.Row Mod 2 = 2 Then Exit Sub
On Error Resume Next
For i = 1 To ActiveSheet.Shapes.Count
    If ActiveSheet.Shapes(i).Left = Target.Offset(1, -6).Left _
    And ActiveSheet.Shapes(i).Top = Target.Offset(1, -6).Top Then
        ActiveSheet.Shapes(i).Delete
    End If
Next i
hata:
On Error GoTo son

ActiveSheet.Pictures.Insert("d:\MSW\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(1, -6).Top
Selection.Left = Target.Offset(1, -6).Left
Selection.ShapeRange.LockAspectRatio = msoFalse
'Selection.ShapeRange.Height = Target.Offset(1, -6).Height
'Selection.ShapeRange.Width = Target.Offset(1, -6).Width
Selection.ShapeRange.Height = 250
Selection.ShapeRange.Width = 242
Target.Select
son:
 'ActiveSheet.Protect
 End Sub

Selam, yukarıdaki kod ile bire bir eşleşen resimleri getirebiliyoruz, ancak ilk 10 karakterleri eşleşiyorsa getirmesini sağlamak için kodda nasıl bir değişiklik yapmalıyız, şimdiden teşekkürler.

 

[Korhan Ayhan]

Deneyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    'ActiveSheet.Unprotect
    If Intersect(Target, [h1:h65536]) Is Nothing Then Exit Sub
    If Target.Row Mod 2 = 2 Then Exit Sub
    On Error Resume Next
    For i = 1 To ActiveSheet.Shapes.Count
        If ActiveSheet.Shapes(i).Left = Target.Offset(1, -6).Left _
        And ActiveSheet.Shapes(i).Top = Target.Offset(1, -6).Top Then
            ActiveSheet.Shapes(i).Delete
        End If
    Next i
hata:
    On Error GoTo son
    Yol = "C:\Users\Korhan AYHAN\Pictures\"
    Dosya = Dir(Yol & Left(Target.Value, 10) & "*.jpg")
    While Dosya <> ""
        ActiveSheet.Pictures.Insert(Yol & "\" & Dosya).Select
        Dosya = Dir
    Wend
    Selection.Top = Target.Offset(1, -6).Top
    Selection.Left = Target.Offset(1, -6).Left
    Selection.ShapeRange.LockAspectRatio = msoFalse
    'Selection.ShapeRange.Height = Target.Offset(1, -6).Height
    'Selection.ShapeRange.Width = Target.Offset(1, -6).Width
    Selection.ShapeRange.Height = 250
    Selection.ShapeRange.Width = 242
    Target.Select
son:
    'ActiveSheet.Protect
End Sub

 

[tahsinanarat]

Sn. Korhan Hocam, çok teşekkür ederim, Allah razı olsun, resim isimlerini değiştirmem gerekmeyecek. Elinize sağlık, Sağolasın.

 

[tahsinanarat]

Slm. Korhan Hocam, gerçek dosyada uygulamaya koyduğumda; h sütununda mevcut bir kodu del tuşu ile sildiğimde resim klasöründe ne kadar resim varsa hepsini getiriyor. Ayrıca biz istiyoruz ki, ilk on karakter eşleştiğinde resim gelsin, resim ismi on karakterden az ise hiç bir işlem yapmasın, umarım anlatabilmişimdir. Teşekkürler.

 

[Korhan Ayhan]

Aşağıdaki gibi deneyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    'ActiveSheet.Unprotect
    If Intersect(Target, [h1:h65536]) Is Nothing Then Exit Sub
    If Target.Row Mod 2 = 2 Then Exit Sub
    On Error Resume Next
    For i = 1 To ActiveSheet.Shapes.Count
        If ActiveSheet.Shapes(i).Left = Target.Offset(1, -6).Left _
        And ActiveSheet.Shapes(i).Top = Target.Offset(1, -6).Top Then
            ActiveSheet.Shapes(i).Delete
        End If
    Next i
    If Target = Empty Then Exit Sub
    If Len(Target) <> 10 Then Exit Sub
hata:
    On Error GoTo son
    Yol = "C:\Users\Korhan AYHAN\Pictures\"
    Dosya = Dir(Yol & Left(Target.Value, 10) & "*.jpg")
    While Dosya <> ""
        ActiveSheet.Pictures.Insert(Yol & "\" & Dosya).Select
        Dosya = Dir
    Wend
    Selection.Top = Target.Offset(1, -6).Top
    Selection.Left = Target.Offset(1, -6).Left
    Selection.ShapeRange.LockAspectRatio = msoFalse
    'Selection.ShapeRange.Height = Target.Offset(1, -6).Height
    'Selection.ShapeRange.Width = Target.Offset(1, -6).Width
    Selection.ShapeRange.Height = 250
    Selection.ShapeRange.Width = 242
    Target.Select
son:
    'ActiveSheet.Protect
End Sub

 

[tahsinanarat]

Sn.Korhan hocam; H sütununda del tuşu olayı düzeldi bu tamam. İstediğimiz H sütununda 10 karakterden az girildiğinde hiç bir işlem yapmasın, hali hazırda h sütununda örn. 15 gibi bir karakter girilip enterlandığında 15 ile başlayan bütün resimler geliyor, biz bu durumda hiç bir işlem yapmamasını istiyoruz. Teşekkürler.

 

[Korhan Ayhan]

#5 nolu mesajımdaki koda küçük bir ekleme daha yaptım. Deneyiniz.

 

[tahsinanarat]

Sn. Korhan hocam bayağı uğraştırdım sizi, hakkını helal edin, tam istediğimiz şekilde oldu, elinize sağlık, çok teşekkür ederim. Saygılar.