DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
yok hocam isim de olsa dert eden eder, sizle ilgili bir konu değil yani...sonuçta herkese açık bir yer...Faturalarınızın orjinali ile bir işimiz yok..
Bu fatura isimlendirme işlemi faturanın bulunduğu klasörde mi olacak? Yoksa masaüstünde yeni bir klasör oluşturulup burada mı yapılacak?
Çünkü yazdıklarınızdan anladığım kadarıyla bir faturanın içinde birden fazla aranan kayıt varsa bu fatura kopyalanarak çoğaltılacak.
Ayrıca isimlerdeki / - gibi sembollerin sorun çıkardığını belirtmişsiniz. Fakat birleştirme işleminde yine - (tire) kullanmışsınız. Bu sorun yaratmayacak mı?
hocam genelde / işareti sorun çıkarıyor, - olmasın derken de güncel isim düz olsun diye dedim, b ve c sütunundaki ifadeler anlaşılsın diye...En son soruma yorum yapmamışsınız sanırım..
Sub Change_Filenames()
Dim S1 As Worksheet, My_Data As Variant, FSO As Object
Dim My_Folder As String, Process_Time As Double
Dim My_Array As Object, Separator As String, X As Long
Dim Search_Text As String, Find_Text As Range
Dim Old_File_Name As String, New_File_Name As String
Process_Time = Timer
Application.ScreenUpdating = False
Set S1 = Sheets("Sayfa1")
Set My_Array = VBA.CreateObject("Scripting.Dictionary")
Set FSO = VBA.CreateObject("Scripting.FileSystemObject")
Separator = Application.PathSeparator
My_Folder = VBA.CreateObject("WScript.Shell").SpecialFolders("Desktop") & Separator & "Arama Sonuçları"
If Dir(My_Folder, vbDirectory) = "" Then MkDir My_Folder
My_Data = S1.Range("D1:F" & WorksheetFunction.Max(2, S1.Cells(S1.Rows.Count, 4).End(3).Row)).Value
For X = LBound(My_Data, 1) To UBound(My_Data, 1)
Search_Text = My_Data(X, 3)
Set Find_Text = S1.Range("A:A").Find(Search_Text, , , xlWhole)
If Not Find_Text Is Nothing Then
If Find_Text.Offset(, 1) <> "" And Find_Text.Offset(, 2) <> "" Then
Old_File_Name = My_Data(X, 1) & Separator & My_Data(X, 2)
New_File_Name = My_Folder & Separator & Replace(Replace(Find_Text.Offset(, 1) & "_" & _
Find_Text.Offset(, 2), "/", ""), "-", "") & _
"." & FSO.GetExtensionName(My_Data(X, 2))
If Not My_Array.Exists(New_File_Name) Then
My_Array.Add New_File_Name, 0
If Dir(New_File_Name) = "" Then
FSO.CopyFile Old_File_Name, New_File_Name
End If
Else
My_Array.Item(New_File_Name) = My_Array.Item(New_File_Name) + 1
New_File_Name = My_Folder & Separator & FSO.GetBaseName(New_File_Name) & "_" & _
My_Array.Item(New_File_Name) & "." & FSO.GetExtensionName(My_Data(X, 2))
If Dir(New_File_Name) = "" Then
FSO.CopyFile Old_File_Name, New_File_Name
End If
End If
End If
End If
Next
My_Array.RemoveAll
Erase My_Data
Set Find_Text = Nothing
Set S1 = Nothing
Set My_Array = Nothing
Set FSO = Nothing
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
"İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye", vbInformation
End Sub
My_Recordset.Open "Select System.ItemName, System.ItemFolderPathDisplay " & _
" From SystemIndex" & _
" Where Scope = 'File:" & Source_Folder & "' " & _
" And Contains('" & Replace(Find_Text, " ", "?") & "')", My_Connection
Neyse ben çözüm olarak Kullanıcılar ve Masaüstü ifadelerini İngilizce'ye çevirerek sonuca gitmeyi tercih ettim. Şimdilik aklıma bu çözüm geldiği için bu yöntemi kullandım. Başka klasörler seçerek işlem yapmak istediğinizde de benzer hatalar oluşabilir. Bu sebeple bu makroyu kullanırken siz de arama yapacağınız klasörü masaüstüne kopyalayıp öyle deneyiniz. (Tabi diğer türlü deneyip kodun hata verme durumunu da kontrol edebilirsiniz.)