Soru Harici Tablo Düzenleme

[SeÖzGü]

Merhaba;
Çalışmış oldugum kurumda sürekli değişken sütün satır aralıklı excel tablolarını çerçeve başlık ekleyip düzenlenmekteyiz bunun içinde ekli makroyu kullanıyorum ama makroda eksikler var yazıcı için de ayrı bir makro kullanıyorum renklendirme var onu kaldırmam gerekiyor ama malesef bi türlü denemelerim sonuç vermedi yeniden de hazırlayamadım desteklerinizi rica ediyorum

Sub HariciDuzenle()
'
' harici Macro
' Harici tablo düzenler
'
' Keyboard Shortcut: Ctrl+Shift+E
'
    ActiveCell.Select

Application.ScreenUpdating = False
Dim lngLstCol As Long, lngLstRow As Long
lngLstRow = ActiveSheet.UsedRange.Rows.Count
lngLstCol = ActiveSheet.UsedRange.Columns.Count
For Each rngCell In Range("A1:A" & lngLstRow)
If rngCell.Value > "" Then
r = rngCell.Row
c = rngCell.Column
Range(Cells(r, c), Cells(r, lngLstCol)).Select
With Selection.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
With Selection.Font
.Size = 8

With Selection
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.WrapText = True
End With
End With
End With
End If
Next
Call boya2
Call Baslik2
Call satirsutun
Application.ScreenUpdating = True
End Sub
Sub boya4()
Range("A:X").Interior.ColorIndex = 0
End Sub

Sub boya2()
Application.ScreenUpdating = False
Dim lngLstCol As Long, lngLstRow As Long
lngLstRow = ActiveSheet.UsedRange.Rows.Count
lngLstCol = ActiveSheet.UsedRange.Columns.Count
For Each rngCell In Range("A1:A" & lngLstRow)
If rngCell.Value > "" Then
r = rngCell.Row
c = rngCell.Column
Range(Cells(1, 1), Cells(1, lngLstCol)).Select

Selection.Interior.ColorIndex = 37

End If
Next
Cells(1, 1).EntireRow.Insert
Application.ScreenUpdating = True
End Sub
Sub Baslik2()
Application.ScreenUpdating = False
Dim lngLstCol As Long, lngLstRow As Long
lngLstRow = ActiveSheet.UsedRange.Rows.Count
lngLstCol = ActiveSheet.UsedRange.Columns.Count
For Each rngCell In Range("A1:A" & lngLstRow)
If rngCell.Value > "" Then
r = rngCell.Row
c = rngCell.Column
Range(Cells(1, 1), Cells(1, lngLstCol)).Select
Selection.Merge

Selection.Interior.ColorIndex = 37
With Selection.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
With Selection.Font
.FontStyle = "Arial"
.Size = 10
With Selection
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
Selection.Font.Bold = True
Cells(1, 1).Value = "Tablo Adı Giriniz!"
End With
End With
End With
End If
Next
Application.ScreenUpdating = True
End Sub
Sub satirsutun()
Dim lngLstCol As Long, lngLstRow As Long
lngLstRow = ActiveSheet.UsedRange.Rows.Count
lngLstCol = ActiveSheet.UsedRange.Columns.Count
Range("A3" & ":" & "A" & lngLstRow).RowHeight = 60
Rows(2).RowHeight = 33.75
End Sub

Sub temizle3()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim lngLstCol As Long, lngLstRow As Long
lngLstRow = ActiveSheet.UsedRange.Rows.Count
lngLstCol = ActiveSheet.UsedRange.Columns.Count
For Each rngCell In Range("A1:A" & lngLstRow)
If rngCell.Value > "" Then
r = rngCell.Row
c = rngCell.Column
Range(Cells(r, c), Cells(r, lngLstCol)).Select
Selection.Clear
End If
Next
Range("A:AZ").ColumnWidth = 8.43
Range("A:A").RowHeight = 15
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 

[SeÖzGü]

desteklerinizi rica ediyorum lütfen