Kapalı dosyadaki özel alt bilgi

[Mukteda]

Arkadaşlar merhaba,

Yaklaşık 350 adet Excel dosyasında özel alt bilgi > sol ve sağ kısım daki bilgileri ve yazı tipini değiştirmem gerekiyor.

Kısa bir yolu var mıdır? Nasıl yapabilirim?

 

[Mukteda]

Peki arkadaşlar,

Soruyu değiştiriyorum. Bir tane makrolu sayfa yapılsa ardından git diğer AÇIK olan Excel sayfasında özel alt bilgi sol kısmı değiştir.

Dosyaları tek tek açarak yapılması mümkün değil midir?

 

[halit3]

Dosyanızdaki bir sayfanın adını data sayfası yapın

A1=ÜST BAŞLIK SOL
A2=ÜST BAŞLIK ORTA
A3=ÜST BAŞLIK SAĞ

A5=ALT BAŞLIK SOL
A6=ALT BAŞLIK ORTA
A7=ALT BAŞLIK SAĞ

B1=ÜST BAŞLIK SOL YAZILACAK
B2=ÜST BAŞLIK ORTA YAZILACAK
B3=ÜST BAŞLIK SAĞ YAZILACAK

B5=ALT BAŞLIK SOL YAZILACAK
B6=ALT BAŞLIK ORTA YAZILACAK
B7=ALT BAŞLIK SAĞ YAZILACAK


KOD:

Sub kapalı_bütün_sayfalara_alt_üst_başlık_koy()

Set Klasor = CreateObject("shell.application").browseforfolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)

If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo atla
'On Error Resume Next
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

Application.DisplayAlerts = False
Application.ScreenUpdating = False


Liste (Kaynak)
MsgBox "işlem tamam", vbInformation, "uyarı"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
    
Set Obj = Nothing
Set Klasor = Nothing
End Sub

Private Sub Liste(yol As String)
Dim fL As Object, f As Object, i As Long
Set fL = CreateObject("Scripting.FileSystemObject")

'On Error Resume Next
For Each dosya In fL.GetFolder(yol).Files


If fL.GetFileName(dosya) = ThisWorkbook.Name Or Mid(fL.GetFileName(dosya), 1, 2) = "~$" Then
GoSub atla1
End If

aranan_Uzanti = fL.GetExtensionName(Application.AddIns.Item(1).FullName)
uzanti = fL.GetExtensionName(dosya)

If aranan_Uzanti = "xlam" Then
If uzanti = "xls" Or uzanti = "xlsm" Or uzanti = "xlsx" Or uzanti = "xlsb" Then

Else
GoSub atla1
End If
End If

If aranan_Uzanti = "xla" Then
If uzanti = "xls" Then

Else
GoSub atla1
End If
End If

Dim wb As Workbook
Set wb = Workbooks.Open(dosya)
For i = 1 To ActiveWorkbook.Sheets.Count
If ActiveWorkbook.Sheets(i).Name <> "[COLOR="Red"]form[/COLOR]" Then

With ActiveWorkbook.Sheets(Sheets(i).Name).PageSetup

'üst
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
' alt
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""

'üst
.LeftHeader = ThisWorkbook.Sheets("data").Cells(1, 2).Value
.CenterHeader = ThisWorkbook.Sheets("data").Cells(2, 2).Value
.RightHeader = ThisWorkbook.Sheets("data").Cells(3, 2).Value
' alt
.LeftFooter = ThisWorkbook.Sheets("data").Cells(5, 2).Value
.CenterFooter = ThisWorkbook.Sheets("data").Cells(6, 2).Value
.RightFooter = ThisWorkbook.Sheets("data").Cells(7, 2).Value
End With

End If
Next
wb.Save
wb.Close

atla1:
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).SubFolders
Liste (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub

NOT Kod sadece kapalı dosyada form sayfasına işlem yapmayacaktır.



Bu kodda başlıkları siliyor.

Sub kapalı_bütün_sayfalara_alt_üst_başlıkları_sil()

Set Klasor = CreateObject("shell.application").browseforfolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)

If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo atla
'On Error Resume Next
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

Application.DisplayAlerts = False
Application.ScreenUpdating = False


Liste (Kaynak)
MsgBox "işlem tamam", vbInformation, "uyarı"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
    
Set Obj = Nothing
Set Klasor = Nothing
End Sub

Private Sub Liste(yol As String)
Dim fL As Object, f As Object, i As Long
Set fL = CreateObject("Scripting.FileSystemObject")

'On Error Resume Next
For Each dosya In fL.GetFolder(yol).Files


If fL.GetFileName(dosya) = ThisWorkbook.Name Or Mid(fL.GetFileName(dosya), 1, 2) = "~$" Then
GoSub atla1
End If

aranan_Uzanti = fL.GetExtensionName(Application.AddIns.Item(1).FullName)
uzanti = fL.GetExtensionName(dosya)

If aranan_Uzanti = "xlam" Then
If uzanti = "xls" Or uzanti = "xlsm" Or uzanti = "xlsx" Or uzanti = "xlsb" Then

Else
GoSub atla1
End If
End If

If aranan_Uzanti = "xla" Then
If uzanti = "xls" Then

Else
GoSub atla1
End If
End If

Dim wb As Workbook
Set wb = Workbooks.Open(dosya)
For i = 1 To ActiveWorkbook.Sheets.Count
If ActiveWorkbook.Sheets(i).Name <> "form" Then

With ActiveWorkbook.Sheets(Sheets(i).Name).PageSetup
'üst
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
' alt
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
End With

End If
Next
wb.Save
wb.Close

atla1:
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).SubFolders
Liste (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub

 

[Mukteda]

halit3 Hocam,

Tamamdır. Mükemmel oldu. Çok çok teşekkür ederim. Var olun, Sağ olun.

Hakkınızı helal ediniz.

 

[halit3]

halit3 Hocam,

Tamamdır. Mükemmel oldu. Çok çok teşekkür ederim. Var olun, Sağ olun.

Hakkınızı helal ediniz.

Teşekkürler iyi çalışmalar