Tabloyu TRM Sekmelerine uygulama

[iaslan517]

Merhabalar, Sayfa 1deki tablo formatını TRM ile başlayan sekmelerdeki verilere uygulatabilirmiyiz? tablo ölçüleri satıra göre fit olacak şekilde. Yardımlarınızı rica ederim. J1 hücresine o günün tarihi de atılmış olabilir mi

 

[mahmut011]

sayfa 1 in tümünün biçim yapısını diğer sayfalara aktarmak için sayfa 1 de satır numaraları ve sütun ismlerinin kesiştiği sol üstteki kısma tıklayarak sayfanın tümümü seçili hale getirin.Giriş menüsünde sol üstteki biçim boyacısına bir kere tıklayın. diğer sayfalara altta sayfa isimleri yazılı sekmelere tıklayarak geçin ve yine o sayfadaki satır numaraları ve sütun isimlerin kesiştiği sayfanın tümünü seçmeye yarayan butona tıklayarak sayfa 1 in tümünün biçim yapısını diğer sayfalara uygulayabilirsiniz. bunu her sayfa için ayrı ayrı yapmak gerekiyor.

Biçim boyacısına alan seçip bir kere tıklayınca biçim 1 kullanımlık oluyor. Çift tıklanırsa bir daha biçim boyacına tıklayıncaya kadar sürekli kullanılabiliyor aynı biçim.

sayfanın tümünün değilde belli, bir kısmının biçimini aktarmak istiyorsanız sayfa 1 de ilgili alanı seçerek diğer sayfalardaki ilgili alanlara biçim boyacısıyla yapıştırın.

Düzeltme: Bunu da makro şeklinde istyorsunuz sanırım. Makro konusunda yardımcı olamayacağım.

 

[iaslan517]

Mahmut hocam oncelikle tesekkur ederim. Bu islemi makro ile yapmam lazim cunku bazen trm ile baslayan sekmeler cogaliyor

 

[numan şamil]

Merhaba
Dener misiniz

Sub numan()
Dim a As Long
On Error Resume Next
Application.ScreenUpdating = False
For a = 1 To Worksheets.Count
 Sheets("Sayfa1").Select
 Cells.Select
    Selection.Copy
    If Sheets(a).Name <> "Sayfa1" Then
    Sheets(a).Cells.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Sheets(a).Range("J1").Value = Date
End If
Next a
Sheets("Sayfa1").Range("J1").Select
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı", vbInformation, ""
End Sub

 

[iaslan517]

Merhaba
Dener misiniz

Sub numan()
Dim i As Long
On Error Resume Next
Application.ScreenUpdating = False
For a = 2 To Worksheets.Count
 Sheets("Sayfa1").Select
 Cells.Select
    Selection.Copy
    If Sheets(a).Name <> "Sayfa1" Then
    Sheets(a).Cells.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Sheets(a).Range("J1").Value = Date
End If
Next a
Sheets("Sayfa1").Range("J1").Select
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı", vbInformation, ""
End Sub

numan hocam öncelikle yardımlarınız için çok teşekkür ederim. fakat tablo değerlerinin üst satırınıda kopyalatabilirmiyiz? bu işlem sadece TRM ilr başlayan sekmeleri için olabilir mi başka sekme olursa ona uygulamasın

 

[numan şamil]

Dener misiniz

Sub numan()
Dim a As Long
On Error Resume Next
Application.ScreenUpdating = False
For a = 1 To Worksheets.Count
 Sheets("Sayfa1").Select
 Cells.Select
    Selection.Copy
    If Mid(Sheets(a).Name, 1, 3) = "TRM" Then
    Sheets(a).Cells.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
End If
Sheets("Sayfa1").Range("A1:I1").Copy
If Mid(Sheets(a).Name, 1, 3) = "TRM" Then
  Sheets(a).Paste
  Sheets(a).Range("J1").Value = Date
  End If
    Application.CutCopyMode = False
Next a
Sheets("Sayfa1").Range("J1").Select
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı", vbInformation, ""
End Sub

 

[numan şamil]

6. nolu mesajımdaki kodlar güncellendi
Sadece ilk harfi "TRM" ile başlayan sayfalara uygulama yapıyor
Denermisiniz

 

[iaslan517]

numan hocam şimdi tamamdır. sadece son olarak olabilitesi varsa sizden bir yardım ricam daha olacak tabloyu trm sekmelerine göre uygularken ilgili TRM sekmesindeki son dolu satıra kadar tablolama işlemi uygulatılabilir mi?

 

[numan şamil]

Kod

Sub numan()
Dim a As Long
On Error Resume Next
Application.ScreenUpdating = False
For a = 1 To Worksheets.Count
 Sheets("Sayfa1").Select
 Cells.Select
    Selection.Copy
    If Mid(Sheets(a).Name, 1, 3) = "TRM" Then
    Sheets(a).Cells.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
End If
Sheets("Sayfa1").Range("A1:I1").Copy
If Mid(Sheets(a).Name, 1, 3) = "TRM" Then
  Sheets(a).Paste
  Sheets(a).Range("J1").Value = Date
   Sheets(a).Range("A2:I5000").Borders.LineStyle = xlNone
  With Sheets(a).Range("A2:I" & Sheets(a).[A5000].End(3).Row).Borders
.LineStyle = xlContinuous
.ColorIndex = 1
.Weight = xlThin
End With
  End If
    Application.CutCopyMode = False
 Next a
Sheets("Sayfa1").Range("J1").Select
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı", vbInformation, ""
End Sub