Sayın
Alicimri hocamın önermiş olduğu kodu ya da aşağıda güncellemiş olduğum kodu kullanırsanız işinizi görecektir.
Çok Teşekkür Ederim Tam istediğim gibi olmuş, Benim kullandığım bir kod var bu kodu kullandığım koddan önce çalışmasını yapamadım.
Aşağıdaki koda yaptığınız kodu eklerseniz sevinirim.
öncelikle klasör seçimi yapılacak
sonra sizin yaptığınız kod devreye girecek
eğer dosyalarda - işareti varsa benim makro çalışacak.
eğer - işareti yoksa uyarı verip makro ilerlemeyecek.
Sub BasliklariDegistir()
Dim Dosya As String, klasorYolu As String
Dim wb As Workbook, ws As Worksheet
Dim basliklar As Variant
Dim i As Long, j As Long
Dim sonSatir As Long
GECENZAMAN = Now()
' Kodun çalıştığı Excel dosyasında A ve B sütunlarındaki eşleşmeleri alır
'With ThisWorkbook.Sheets(2) ' Eğer farklı bir sayfa ise sayfa adını değiştir
With ThisWorkbook.Sheets("Başlıklar") ' Eğer farklı bir sayfa ise sayfa adını değiştir
sonSatir = .Cells(.Rows.Count, "A").End(xlUp).Row
basliklar = .Range("A2:B" & sonSatir).Value
End With
' Klasör seçmek için gözat penceresi açılır
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Lütfen klasörü seçiniz"
If .Show = -1 Then
klasorYolu = .SelectedItems(1) & "\"
Else
Exit Sub ' Eğer klasör seçilmezse işlemi iptal et
End If
End With
Application.ScreenUpdating = False ' Ekran güncellemeyi kapat
' Klasördeki tüm Excel dosyalarını döngüye al
Dosya = Dir(klasorYolu & "
.xls")
Do While Dosya <> ""
Debug.Print "İşlenen dosya: " & Dosya ' Hangi dosyada çalıştığını görmek için
' Her Excel dosyasını aç
Set wb = Workbooks.Open(klasorYolu & Dosya)
' Eğer dosya açılmadıysa kontrol et
If wb Is Nothing Then
MsgBox "Dosya açılamadı: " & Dosya
Exit Sub
End If
' Boş dosya kontrolü
If wb.Worksheets.Count = 0 Then
MsgBox "Boş dosya: " & wb.Name
wb.Close SaveChanges:=False
Dosya = Dir
GoTo DevamEt
End If
' Tüm sayfalar üzerinde işlem yapılır
For Each ws In wb.Worksheets
' İlk satır tamamen boşsa silinir
If Application.WorksheetFunction.CountA(ws.Rows(1)) = 0 Then
ws.Rows(1).Delete
End If
'On Error Resume Next
'Alt Toplam Olan satırları kaldır.
Selection.RemoveSubtotal
'Tabloda fazla boş satır ve sutunları siler
Fazla_Satır_Sutunları_Sil
'Aktif sayfa adını Sayfa1 olarak değiştir
ActiveSheet.Name = "Sayfa1"
'Sayfa1'i başlıkları kırp
Sayfa_Kırp
' İlk satırdaki başlıkları kontrol eder ve değiştirir
For i = 1 To ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
For j = LBound(basliklar) To UBound(basliklar)
If ws.Cells(1, i).Value = basliklar(j, 1) Then
ws.Cells(1, i).Value = basliklar(j, 2)
Exit For
End If
Next j
Next i
Next ws
' Dosyayı kaydet ve kapat
wb.Close SaveChanges:=True
DevamEt:
' Bir sonraki dosyaya geç
Dosya = Dir
Loop
MsgBox "Başlıklar başarıyla güncellendi." & vbCr & "Geçen Zaman : " & Format(Now() - GECENZAMAN, "hh:mm:ss"), vbInformation, "Bilgi"
Application.ScreenUpdating = True ' Ekran güncellemeyi aç
End Sub
