Resim Konumunu Excele Aktarma Makrosu

[ReostaTR]

İyi günler.Elimdeki resimleri klasöre çıkartıyorum.Daha sonra ilgili resime klasördeki konumunu atama yapmam lazım fakat ufak bir karmaşıklık var.Konumları çekerken image1 den başlayıp image 10a atlıyor ve resimler bitinceye kadar 11 12 diye sıralı gidiyor ardından image 2 den devam ediyor.Benim isteğim image1 den başlayıp son resime kadar gitmesi. Sorunum ekran görüntüleriyle daha anlaşılır hale gelecektir.

Elimdeki kod:

Sub PictureNametoExcel()
'UpdatebyExtendoffice201709027
Dim I As Long
Dim xRg As Range
Dim xAddress As String
Dim xFileName As String
Dim xFileDlg As FileDialog
Dim xFileDlgItem As Variant
On Error Resume Next
xAddress = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Select a cell to place name list:", "KuTools For Excel", xAddress, , , , , 8)
If xRg Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set xRg = xRg(1)
xRg.Value = "Picture Name"
With xRg.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
End With
xRg.EntireColumn.AutoFit
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
I = 1
If xFileDlg.Show = -1 Then
xFileDlgItem = xFileDlg.SelectedItems.Item(1)
xFileName = Dir(xFileDlgItem & "\")
Do While xFileName <> ""
If InStr(1, xFileName, ".jpg") + InStr(1, xFileName, ".png") + InStr(1, xFileName, ".img") + InStr(1, xFileName, ".jpeg") + InStr(1, xFileName, ".bmp") > 0 Then
xRg.Offset(I).Value = xFileDlgItem & "\" & xFileName
I = I + 1
End If
xFileName = Dir
Loop
End If
Application.ScreenUpdating = True
End Sub

 

[ReostaTR]

Hatanın resmi:
https://ibb.co/fK96tc
isteğim image 1,2,3 şeklinde ardışık atması

 

[Merhum İdris SERDAR]

.

I = 10

yaparsanız olur sanırım. Ama 1'den değil 10'dan başlar.


.

 

[Korhan Ayhan]

Klasördeki resimlerin isimlerini "image 1" , "image2" gibi değilde aşağıdaki gibi düzenlerseniz istediğiniz sonuca ulaşabilirsiniz.

İmage 0001
İmage 0002
................
................
İmage 0010

DIR komutu sorgulama esnasında windowsun klasik sıralama sistemine göre değer döndürüyor. Sorun bundan kaynaklanıyor.

Bunu şu şekilde test edebilirsiniz. İlgili klasörü açın ve dosyaları sıralamayı deneyin.