Muharrem DOĞANCI: Excel VBA ile Windows'ta Toplu Dosya Adı Değiştirmek

9 Nisan 2024 Salı

Excel VBA ile Windows'ta Toplu Dosya Adı Değiştirmek

"islem" sayfası

KLASÖR YOLU

ORİJİNAL DOSYA ADI

UZANTI

YENİ DOSYA ADI

"dizi" sayfası

DİZİ	DÖNÜŞÜM	AYRAÇ
0	0	_
1	1
2	2
3	3
4	4
5	5
6	6
7	7
8	8
9	9
A	A
B	B
C	C
D	D
E	E
F	F
G	G
H	H
I	I
J	J
K	K
L	L
M	M
N	N
O	O
P	P
R	R
S	S
T	T
U	U
V	V
Y	Y
Z	Z
Q	Q
W	W
X	X
a	a
b	b
c	c
d	d
e	e
f	f
g	g
h	h
i	i
j	j
k	k
l	l
m	m
n	n
o	o
p	p
r	r
s	s
t	t
u	u
v	v
y	y
z	z
q	q
w	w
x	x
_	_
-	_
Â	A
Ç	C
Ğ	G
İ	I
Î	I
Ö	O
Ş	S
Ü	U
Û	U
â	a
ç	c
ğ	g
ı	i
ö	o
ş	s
û	u
ü	u
é	e
ä	a
ï	i
Ô	O
ô	o
ã	a
Ã	A
Ä	A
Í	I
í	i
Ú	U
ú	u
Ó	O
ó	o
É	E
î	i

"panel" sayfası

Bu sayfa zorunlu değildir.

mod_Tek_Klasor_Sec

Dim FSO As Scripting.FileSystemObject 'FSO: File System Object
Dim fls As Object 'fls: files: dosyalar
Dim lr As Long
Dim i As Long
Dim ayrac As String
Dim mf As String 'mf: main folder: kok klasor
Sub Tek_Klasor_Sec()

Call mod_Temel_Kontrol.Alani_Kontrol_Et

Set FSO = New Scripting.FileSystemObject
ayrac = Application.PathSeparator

lr = dad.Cells(Rows.Count, 1).End(xlUp).Row
dad.Range("A2").Resize(lr, 4).ClearContents

i = 2
With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = -1 Then
        mf = .SelectedItems(1)
        For Each fls In FSO.GetFolder(mf).Files
            dad.Range("A" & i) = FSO.GetFolder(mf) & ayrac
            dad.Range("B" & i) = "'" & FSO.GetBaseName(fls)
            dad.Range("C" & i) = FSO.GetExtensionName(fls)
            i = i + 1
        Next fls
    Else
        Exit Sub
    End If
End With

lr = dad.Cells(Rows.Count, 1).End(xlUp).Row
If lr <= 1 Then
    MsgBox "Sectiginiz klasor ve altlari bos.", vbInformation
End If

End Sub

mod_Cok_Klasor_Sec

Dim FSO As Scripting.FileSystemObject 'FSO: File System Object
Dim mf As String 'mf: main folder: kok klasor
Dim lr As Long

Dim act_fol As Scripting.Folder
Dim sub_fol As Scripting.Folder
Dim fls As Scripting.File 'fls: files: dosyalar
Dim arr() As Variant
Dim i As Long
Sub Klasoru_ve_Altindakileri_Sec()

Set FSO = New Scripting.FileSystemObject

'Application.SendKeys "^g", True
'Application.SendKeys "^a", True
'Application.SendKeys "{DEL}", True

Call mod_Temel_Kontrol.Alani_Kontrol_Et

With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = -1 Then
        mf = .SelectedItems(1)
    Else
        Exit Sub
    End If
End With

lr = dad.Cells(Rows.Count, 1).End(xlUp).Row
dad.Range("A2").Resize(lr, 4).ClearContents
ayrac = Application.PathSeparator

Call Sub_Folder_Files(FSO.GetFolder(mf).Path)

lr = dad.Cells(Rows.Count, 1).End(xlUp).Row
If lr <= 1 Then
    MsgBox "Sectiginiz klasor ve altlari bos.", vbInformation
End If

End Sub
Function Sub_Folder_Files(sfn As String)
'sfn: sub folder name: alt klasor adi
Set FSO = New Scripting.FileSystemObject
Set act_fol = FSO.GetFolder(sfn)
i = 1

If act_fol.Files.Count >= 1 Then
    ReDim arr(1 To act_fol.Files.Count, 1 To 3)
    For Each fls In act_fol.Files
        arr(i, 1) = sfn & ayrac
        arr(i, 2) = "'" & CStr(FSO.GetBaseName(fls))
        arr(i, 3) = CStr(FSO.GetExtensionName(fls))
        i = i + 1
    Next fls

    lr = dad.Cells(Rows.Count, 1).End(xlUp).Row
    dad.Range("A" & lr + 1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr()
    'UBound(arr, 1) dizinin toplam satir sayisini verir
    'UBound(arr, 2) dizinin toplam sutun sayisini verir
End If

For Each sub_fol In act_fol.SubFolders
    Sub_Folder_Files sub_fol.Path
    'Recursive Programming _
    https://youtu.be/hT2ufvY9b6w?t=1445
Next sub_fol

End Function

mod_SEO_URL_Uret

Dim i As Long
Dim j As Long
Dim k As Long
Dim m As Long
Dim lr1  As Long
Dim lr2 As Long
Dim K1 As String
Dim K2 As String
Dim Ayrac2 As String
Dim Arr1 As Variant
Sub SEO_URL_Normal()
SEO_URL_3 ("orijinal_harf")
End Sub
Sub SEO_URL_UCase()
SEO_URL_3 ("buyuk_harf")
End Sub
Sub SEO_URL_LCase()
SEO_URL_3 ("kucuk_harf")
End Sub
Sub SEO_URL_vbProperCase()
SEO_URL_3 ("buyuk_kucuk_harf")
End Sub
Function SEO_URL_3(harf_duzeni As String)

Call mod_Temel_Kontrol.Alani_Kontrol_Et

lr1 = dad.Cells(Rows.Count, 1).End(xlUp).Row
lr2 = dizi.Cells(Rows.Count, 1).End(xlUp).Row

If lr1 <= 1 Then
    MsgBox "Icinde dosya oldugundan emin oldugunuz bir klasor seciniz.", vbExclamation
    Exit Function
End If

dad.Range("D2").Resize(lr1, 1).ClearContents

For i = 2 To lr2
    K1 = K1 & dizi.Range("A" & i).Value2
    K2 = K2 & dizi.Range("B" & i).Value2
Next i

Ayrac2 = dizi.Range("C2").Value2
Arr1 = dad.Range("B2:B" & lr1 + 1)
ReDim Arr2(1 To UBound(Arr1), 1 To 1)
j = 1: k = 1
For i = 1 To UBound(Arr1)
    If harf_duzeni = "buyuk_kucuk_harf" Then
        Arr1(i, 1) = StrConv(Arr1(i, 1), vbProperCase)
        If UBound(Split(Arr1(i, 1), " ")) > 0 Then
            For m = 0 To UBound(Split(Arr1(i, 1), " "))
                If InStr(1, Split(Arr1(i, 1), " ")(m), Chr(221)) > 1 Then
                    Arr1(i, 1) = Replace(Arr1(i, 1), Chr(221), "i")
                End If
            Next m
        End If
    End If
    If harf_duzeni = "buyuk_harf" Then
        Arr1(i, 1) = StrConv(Arr1(i, 1), vbUpperCase)
    End If
    If harf_duzeni = "kucuk_harf" Then
        Arr1(i, 1) = StrConv(Arr1(i, 1), vbLowerCase)
        Arr1(i, 1) = Replace(Arr1(i, 1), Chr(221), "i")
    End If
    Arr2(k, 1) = "'"
    Do
        If InStr(1, K1, Mid(Arr1(i, 1), j, 1)) > 0 Then
            Arr2(k, 1) = Arr2(k, 1) & Mid(K2, InStr(1, K1, Mid(Arr1(i, 1), j, 1)), 1)
            j = j + 1
        Else
            Arr2(k, 1) = Arr2(k, 1) & Ayrac2
            j = j + 1
        End If
        Arr2(k, 1) = Replace(Arr2(k, 1), Ayrac2 & Ayrac2, Ayrac2)
    Loop Until j > Len(Arr1(i, 1))
    If Left(Arr2(k, 1), 1) = Ayrac2 Then
        Arr2(k, 1) = Right(Arr2(k, 1), Len(Arr2(k, 1)) - 1)
    End If
    If Right(Arr2(k, 1), 1) = Ayrac2 Then
        Arr2(k, 1) = Left(Arr2(k, 1), Len(Arr2(k, 1)) - 1)
    End If
    j = 1: k = k + 1
Next i

dad.Range("D2:D" & UBound(Arr2)) = Arr2

End Function

mod_Sira_No_Uret

Dim das As Long 'das: dosya ad sayisi
Dim lr As Long
Dim sira_no As Long
Dim toplayici As Long
Dim ilk_deger As Long
Dim en_uzun_basamak As Long
Dim arr() As Variant
Sub Sira_Numarasi_Uret()

Call mod_Temel_Kontrol.Alani_Kontrol_Et

das = WorksheetFunction.CountA(dad.Range("B2:B" & Rows.Count))
lr = dad.Cells(Rows.Count, 2).End(xlUp).Row
If lr <= 1 Then
    MsgBox "Icinde dosya oldugundan emin oldugunuz bir klasor seciniz.", vbExclamation
    Exit Sub
End If

On Error Resume Next
sira_no = InputBox("0'den buyuk bir tam sayi giriniz.")
ilk_deger = sira_no
toplayici = InputBox("Artirma islemi icin bir tam sayi giriniz.")
If sira_no = 0 Or toplayici = 0 Then
    Exit Sub
End If
On Error GoTo 0

For i = 1 To das
    If i = das Then Exit For
    sira_no = sira_no + toplayici
Next i
If sira_no > 0 Then
    en_uzun_basamak = sira_no
End If
sira_no = ilk_deger

ReDim arr(1 To das, 1 To 1)
For i = 1 To das
    If Len(CStr(en_uzun_basamak)) > Len(CStr(das)) Then
        arr(i, 1) = "'" & WorksheetFunction.Rept("0", Len(CStr(en_uzun_basamak)) - Len(CStr(sira_no))) & sira_no
    ElseIf Len(CStr(en_uzun_basamak)) < Len(CStr(das)) Then
        arr(i, 1) = "'" & WorksheetFunction.Rept("0", Len(CStr(das)) - Len(CStr(sira_no))) & sira_no
    Else
        arr(i, 1) = sira_no
    End If
    sira_no = sira_no + toplayici
Next i

dad.Range("D2").Resize(UBound(arr), 1) = arr()
en_uzun_basamak = 0
das = 0
lr = 0
sira_no = 0
toplayici = 0
ilk_deger = 0
Erase arr
End Sub

mod_Sira_no_Uret_Ters

Dim das As Long 'das: dosya ad sayisi
Dim lr As Long
Dim sira_no As Long
Dim cikarici As Long
Dim ilk_deger As Long
Dim en_uzun_basamak As Long
Dim arr() As Variant
Sub Sira_Numarasi_Uret()

Call mod_Temel_Kontrol.Alani_Kontrol_Et

das = WorksheetFunction.CountA(dad.Range("B2:B" & Rows.Count))
lr = dad.Cells(Rows.Count, 2).End(xlUp).Row
If lr <= 1 Then
    MsgBox "Icinde dosya oldugundan emin oldugunuz bir klasor seciniz.", vbExclamation
    Exit Sub
End If

On Error Resume Next
sira_no = InputBox(das & "'den buyuk bir tam sayi giriniz.")
ilk_deger = sira_no
cikarici = InputBox("Eksiltme islemi icin bir tam sayi giriniz.")
If sira_no = 0 Or cikarici = 0 Then
    Exit Sub
End If
On Error GoTo 0

For i = 1 To das
    If i = das Then Exit For
    sira_no = sira_no - cikarici
    If sira_no <= 0 Then
        MsgBox "Eksiltme katsayisini daha dusuk giriniz.", vbExclamation
        Exit Sub
    End If
Next i
If sira_no > 0 Then
    en_uzun_basamak = ilk_deger
End If
sira_no = ilk_deger

ReDim arr(1 To das, 1 To 1)
For i = 1 To das
    If Len(CStr(en_uzun_basamak)) > Len(CStr(das)) Then
        arr(i, 1) = "'" & WorksheetFunction.Rept("0", Len(CStr(en_uzun_basamak)) - Len(CStr(sira_no))) & sira_no
    ElseIf Len(CStr(en_uzun_basamak)) < Len(CStr(das)) Then
        arr(i, 1) = "'" & WorksheetFunction.Rept("0", Len(CStr(das)) - Len(CStr(sira_no))) & sira_no
    Else
        arr(i, 1) = sira_no
    End If
    sira_no = sira_no - cikarici
Next i

dad.Range("D2").Resize(UBound(arr), 1) = arr()
en_uzun_basamak = 0
das = 0
lr = 0
sira_no = 0
cikarici = 0
ilk_deger = 0
Erase arr
End Sub

mod_Tarih_Uret

Dim Simdi As Date
Dim tarih_format As String
Dim Ayrac2 As String
Dim i As Long
Dim das As Long 'das: dosya ad sayisi
Dim lr As Long
Dim arr() As Variant
Sub Tarih_Uret()

Call mod_Temel_Kontrol.Alani_Kontrol_Et

das = WorksheetFunction.CountA(dad.Range("B2:B" & Rows.Count))
lr = dad.Cells(Rows.Count, 2).End(xlUp).Row
If lr <= 1 Then
    MsgBox "Icinde dosya oldugundan emin oldugunuz bir klasor seciniz.", vbExclamation
    Exit Sub
End If

Ayrac2 = dizi.Range("C2").Value2
tarih_format = InputBox("Lutfen Excel'in destekledigi bir tarih formati giriniz" & vbNewLine & _
    "Ornek: yyyymmdd ddd_hhmmss" & vbNewLine & _
    "Cikti: " & Format(Now, "yyyymmdd") & Format(Now, "ddd") & "_" & Format(Now, "hhmmss"))

If tarih_format = "" Then
    Exit Sub
End If

ReDim arr(1 To das, 1 To 1)
Simdi = Now()
For i = 1 To das
    If tarih_format = "yyyymmdd ddd_hhmmss" Then
        arr(i, 1) = Format(Simdi, "yyyymmdd") & Format(Simdi, "ddd") & "_" & Format(Simdi, "hhmmss")
        Simdi = Simdi + TimeValue("00:00:01")
    Else
        arr(i, 1) = Format(Simdi, tarih_format) & Ayrac2 & i
    End If
    arr(i, 1) = Replace(arr(i, 1), Chr(199), "C")
Next i

dad.Range("D2").Resize(UBound(arr), 1) = arr()

End Sub

mod_Ad_Degistir

Dim yol As String
Dim orijinal_dosya_ad As String
Dim yeni_ad As String
Dim uzanti As String
Dim lr As Long
Dim satir_no As Long
Dim FSO As Scripting.FileSystemObject
Sub Dosya_Adi_Degistir()
Set FSO = New Scripting.FileSystemObject
Call mod_Temel_Kontrol.Alani_Kontrol_Et

lr = dad.Cells(Rows.Count, 2).End(xlUp).Row
satir_no = 2

If lr <= 1 Then
    MsgBox "Icinde dosya oldugundan emin oldugunuz bir klasor seciniz.", vbExclamation
    Exit Sub
End If

Do While dad.Range("A" & satir_no) <> ""
    yol = dad.Range("A" & satir_no)
    orijinal_dosya_ad = dad.Range("B" & satir_no)
    uzanti = dad.Range("C" & satir_no)
    yeni_ad = dad.Range("D" & satir_no)
    If uzanti <> "" Then
        If FSO.FileExists(yol & orijinal_dosya_ad & "." & uzanti) = True Then
        'Verilen dizin ifadesinde dosya var ise degisiklik yap
            If FSO.FileExists(yol & yeni_ad & "." & uzanti) = False Then
            'Yeni adda dosya yoksa degisiklik yap
                If yol & orijinal_dosya_ad & "." & uzanti <> yol & yeni_ad & "." & uzanti Then
                'Ozgun dosya adi, yeni ada esit degilse ad degistir
                    FSO.MoveFile yol & orijinal_dosya_ad & "." & uzanti, yol & yeni_ad & "." & uzanti
                End If
            End If
        End If
    Else
        If FSO.FileExists(yol & orijinal_dosya_ad) = True Then
        'Verilen dizin ifadesinde dosya var ise degisiklik yap
            If FSO.FileExists(yol & yeni_ad) = False Then
            'Yeni adda dosya yoksa degisiklik yap
                If yol & orijinal_dosya_ad <> yol & yeni_ad Then
                'Ozgun dosya adi, yeni ada esit degilse ad degistir
                    FSO.MoveFile yol & orijinal_dosya_ad, yol & yeni_ad
                End If
            End If
        End If
    End If
    satir_no = satir_no + 1
Loop

End Sub

mod_Alani_Temizle

Dim lr As Long
Sub Alani_Temizle()

Call mod_Temel_Kontrol.Alani_Kontrol_Et

lr = dad.Cells(Rows.Count, 1).End(xlUp).Row
dad.Range("A2").Resize(lr, 4).ClearContents
dad.Activate
ThisWorkbook.Save
End Sub

mod_Temel_Kontrol

Sub Alani_Kontrol_Et()
If dad.Range("A1") = "" Then
    dad.Range("A1").Value2 = "KLASOR YOLU"
    Call Bold_Yap
End If
If dad.Range("B1") = "" Then
    dad.Range("B1").Value2 = "ORIJINAL DOSYA ADI"
    Call Bold_Yap
End If
If dad.Range("C1") = "" Then
    dad.Range("C1").Value2 = "UZANTI"
    Call Bold_Yap
End If
If dad.Range("D1") = "" Then
    dad.Range("D1").Value2 = "YENI DOSYA ADI"
    Call Bold_Yap
End If
End Sub
Function Bold_Yap()
dad.Range("A1:D1").Font.Bold = True
End Function

Muharrem DOĞANCI

Bu Blogda Ara

9 Nisan 2024 Salı

Excel VBA ile Windows'ta Toplu Dosya Adı Değiştirmek

Hiç yorum yok:

Yorum Gönder