Hücre içinden belirli metni silmek

[vurkan]

Arkadaşlar Merhaba.
İnternetten indirdiğim e kitaplarla sanal kütüphane oluşturuyorum. Aldığım kitaplarda yazar ve kitabın ismi haricinde aşağıdaki örnekler gibi fazlalıklar oluyor.
Daha önce edindiğim bir kod sayesinde klasördeki dosya adlarını excele B2:B sütununa alıyorum. Buraya aldığım isimlerden bu fazlalıkları çıkarıp kitap isimlerini sade bir şekilde büyük harfe çevirerek değiştirmek istiyorum. Mesela ( PDFDrive.com ) ibaresi yaklaşık 1000 kitapta var. Bazılarının başında ve sonunda örnektekine benzer rakamlar var.
Bu fazlalıklardan nasıl kurtulabilirim. Saygılar

0869-Felsefenin_Oykusu-1-Yunan_Ve_Ortachagh_Felsefesi-Frank_Thilly-2000-400s

A'dan Z'ye Felsefe - Alexander Moseley ( PDFDrive.com )

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu deneyiniz.

Option Explicit

Sub Verileri_Duzenle()
    Dim X As Long, Son As Long, Y As Integer, Veri As Variant, Sonuc As String
    
    Son = Cells(Rows.Count, 2).End(3).Row
    
    Range("B:B").Replace " ( PDFDrive.com )", "", xlPart
    
    For X = 2 To Son
        If InStr(1, Cells(X, 2), "-") > 0 Then
            Veri = Split(Cells(X, 2), "-")
            For Y = 0 To UBound(Veri)
                If Y = 0 Or Y = UBound(Veri) Or Y = UBound(Veri) - 1 Then
                    If Not IsNumeric(Mid(Veri(Y), 1, 1)) Then
                        Sonuc = Sonuc & "-" & Veri(Y)
                    End If
                Else
                    Sonuc = Sonuc & "-" & Veri(Y)
                End If
            Next
            If Sonuc <> "" Then
                Sonuc = Mid(Sonuc, 2, Len(Sonuc) - 1)
                Veri = Split(Sonuc, "-")
                Sonuc = ""
                For Y = 0 To UBound(Veri) - 1
                    Sonuc = Sonuc & "-" & UCase(Replace(Replace(Veri(Y), "ı", "I"), "i", "İ"))
                Next
                Sonuc = Sonuc & "-" & Veri(UBound(Veri))
                Cells(X, 2) = Mid(Sonuc, 2, Len(Sonuc) - 1)
                Sonuc = ""
            End If
        End If
    Next

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[vurkan]

Üstadım merhaba Verdiğiniz kodu çalıştırdım. İşlem oldukça uzun sürmesine rağmen fazlalıkları aldı. Çok teşekkür ediyorum. Başka dosya isimlerinde de fazlalıklardan kurtulmak için kodun içine değil de mesela bir hücrenin içine yazılan veriden kurtulmak şeklinde olsa daha iyi mi olurdu acaba? Saygılar sunuyorum.

 

[Haluk]

Bu iş aslında tam olarak "Regular Expressions" konusu.....

Ama; sadece 2 tane değil, daha fazla sayıda sorunlu kitap isimlerinden görmek lazım....

.

 

[Korhan Ayhan]

Ne kadar veride denediniz? Ne kadar sürüyor?

 

[vurkan]

Üstadım 1400 veride denedim. İşlem yaparken yaklaşık 2 dakika sonra bilgisayarın başından ayrıldım. döndüğümde bitmişti. Tam bilemiyorum.

Haluk Bey merhaba; İnternetten indirdiğim bazı kitap isimleri aşağıdaki gibi Yapmaya çalıştığım şey bu dosya adlarını bir excel dosyasına alıp olumlu değişikliği yaptıktan sonra aynı dosyaların adını yenisiyle değiştirmek. saygılar sunuyorum.

YETMIS_UC_FIRKA_VE_EHLI_SUNNET
IMAM-GAZALI-LEDUN-VE-TEVHID-RISALELERI
ALİ B. osMA.N EL-oşi'NiN (ö. 5751179) EL-EMALi
B U H A Ri
documents%5C_dosyalar%5C_pdfler%5CTurkce_Makaleler_icin_Referans_Kurallari

 

[Korhan Ayhan]

Merhaba Vurkan Bey,

Ben ilk mesajınızda verdiğiniz iki satırlık örnekten 5.000 satır kopyaladım. Boş bir excel dosyasında denedim. Makro yaklaşık 3 saniyede tamamlandı.

Sizi asıl dosyanızda farklı bir durum olabilir.

Örnek dosya ektedir.

Harici Link (Silinebilir) ; https://we.tl/t-r25ZANG8QN

 

[vurkan]

Merhaba bendeki dosya adlarını sizin örneğe yapıştırıp denedim. 0,16 saniye sürdü. Ama bazı dosya isimlerini büyütmedi. Saygılar.

https://dosya.co/813ob2p32id1/Örnek_Dosya_(Vurkan_Bey).xlsm.html

 

[Korhan Ayhan]

Büyük harfe çevirme işlemi cümledeki "-" işaretlerine bakılarak yapılıyor. En sonda bulunan tire işaretinden sonraki blok dışında büyük harfe çevriliyor.

Bazıları küçük harf kalıyor. Çünkü içinde hiç tire işareti yok. Bu durumda cümlenin tamamı büyük harf mi olsun?

Ayrıca bazı cümlelerin sonunda ".pdf" kalıyor. Sanırım bunlarda silinecek.

 

[vurkan]

Üstadım .pdf klasörden dosya adlarını alan kodlar dosya uzantılarıyla alıyor. Evet dosya adları büyük harf olursa daha rahat okunur diye düşünüyorum.

Benim hedefimde şu ana kadar oluşturduğum yaklaşık 25.000 kitabı belli kriterlere göre tasnif edip bu kitapların listelerini tutabileceğim bir dosya oluşturmak. Bir kitap aradığımda veya okuduğumda kolayca bulmak. Bu amaçla kitap adlarını düzgünce tutmak için hepsini kitap adı ve yazarı olacak şekle sokmak.
Ama bazen tek tek bazen zipli halde bir çok kitap indirdim. Hala da indiriyorum. Ama bir kitap bende var mı yok mu bilmeden indirdiğimden bazen mükerrer bazen de uygunsuz kitaplar indirebiliyorum. Onları ayıklamam da oldukça zaman alıyor.

Daha önce halit Beyin kodlarıyla dosyaların adlarını büyük harfe çeviren bir kod edinmiştim.

Bir başka kodla da klasördeki kitap adlarını bir excel dosyasına alıyorum ki o dosyayı ekleyeceğim. Bu dosyada da bir ufak değişiklik yapılabilirse mükemmel olur. Şöyle ki:

Klasördeki Dosyalar adlı dosyadaki kod ile seçilen klasör içindeki dosyaları alıyor ve "dosya adı" altına yazıyor. (Oysa klasörün adını yazsa daha iyi olurdu.) Ancak alt klasörler içindeki dosyaları almıyor. Benim mesela dini kitapları biriktirdiğim klasörün adı DİNİ onun alt klasörleri ise mesela; AKAİD KELAM HADİS FIKIH .... böyle gidiyor. Bu kodlarla seçim yaparken her klasörü ayrı ayrı seçip almak zorunda kalıyorum.

Eğer mümkün ise DİNİ klasörünü seçip kodu çalıştırdığımda DİNİ başlığı altına AKAİD yazıp dosyalarını, KELAM yazıp dosyalarını ........alabilse çok güzel olurdu.
Mesela aynı kitaptan birden fazla varsa seçim yaparak o dosya üzerinden direkt geri dönüşüme gönderilebilse harika olurdu. Saygılar.

https://dosya.co/o758yyexw4mt/Klasordeki_Dosyalar.xlsm.html

 

[vurkan]

Üstadım dosyaya sizin kodları da ekledim ama bir şeyleri yanlış yapıyorum galiba ki istediğim sonuç olmuyor. Saygılar.

https://dosya.co/8r5ig028yktu/KİTAPLIK_PROGRAMI_v1.xlsm.html

 

[Korhan Ayhan]

Kod problemli kelimeler birebir aynı olursa değiştirme işlemi yapar. Bu sebeple sonuç alamıyorsunuz. Dediğiniz gibi kod içinde değişecek kelimeleri belirtmek yerine sayfada bir sütun belirlenerek bu sütuna yazılacak tüm kelimeler veri kümesinde değiştirilebilir. Böylece daha sağlıklı sonuç alınabilir.

 

[vurkan]

Evet sayın üstadım. Geç cevap verdiğim için özür dilerim. Şehir dışındaydım. Bunun için nasıl bir ilave gerekli acaba. Teşekkürler.

 

[Korhan Ayhan]

Dosyanız ektedir.

Veri kümesinden değiştirmek-silmek istediğiniz verileri hücreye yazarak yönetebilirsiniz.

Harici Link (Silinebilir) ; https://we.tl/t-fB3P6DLOHU

 

[vurkan]

Sayın üstadım. Yüreğine sağlık çok kullanışlı olmuş.
Diğer kitapları aldığım kodlar için ilave yapılabilir mi? Şöyle ki;

Mevcut kod ile seçilen klasör içindeki dosyaları alıyor ve "dosya adı" altına yazıyor. (Oysa klasörün adını yazsa daha iyi olurdu.) Ancak alt klasörler içindeki dosyaları almıyor. Benim mesela dini kitapları biriktirdiğim klasörün adı DİNİ onun alt klasörleri ise mesela; AKAİD KELAM HADİS FIKIH .... böyle gidiyor. Bu kodlarla seçim yaparken her klasörü ayrı ayrı seçip almak zorunda kalıyorum.

Eğer mümkün ise DİNİ klasörünü seçip kodu çalıştırdığımda DİNİ başlığı altına AKAİD yazıp dosyalarını, KELAM yazıp dosyalarını ........alabilse çok güzel olurdu. Saygılar.

Sub FileNametoExcel()
'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:", "Excel.web.tr", xAddress, , , , , 8)
If xRg Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set xRg = xRg(1)
xRg.Value = "Dosya Adı"
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 <> ""
'***************************************************************************************************************************************************************************************
'******bu satırda dosya uzantılarını kendin belirleyebilirsin. + InStr(1, xFileName, ".xxx" şeklinde dosya adı uzantısı ekleyerek çekmek istediğin uzantıları çekebilirsin.*****
If InStr(1, xFileName, ".XLSM") + InStr(1, xFileName, ".xlsm") + InStr(1, xFileName, ".XLS") + InStr(1, xFileName, ".xls") + InStr(1, xFileName, ".pdf") + InStr(1, xFileName, ".PDF") + InStr(1, xFileName, ".docx") + InStr(1, xFileName, ".DOCX") + InStr(1, xFileName, ".doc") + InStr(1, xFileName, ".DOC") + InStr(1, xFileName, ".epub") + InStr(1, xFileName, ".EPUB") > 0 Then
'***************************************************************************************************************************************************************************************
xRg.Offset(I).Value = xFileName
I = I + 1
End If
xFileName = Dir
Loop
End If
Worksheets("Sheet1").Columns("A").AutoFit

Application.ScreenUpdating = True
End Sub