• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

kenarlık-çerçeve yapımı

Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...
M

muratkul

Katılım
27 Ocak 2009
Mesajlar
243
Excel Vers. ve Dili
EXCEL2003,TÜRKÇE
Merhabalar,
Ekteki dosyada olduğu gibi her numara değiştiğinde aynı numaraları çerçeve içine almasını istiyorum.YArdımcı olabilirmisiniz.
 

Ekli dosyalar

Sayfanın kodu olarak kopyalayınız.
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [C9:C10000]) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
 ActiveWindow.DisplayGridlines = False
Dim i As Integer
son = Cells(65536, "C").End(3).Row
Range("A9:R" & son + 1).Select
Selection.Borders.LineStyle = 0
Range("A9:R" & son).Select
Selection.Borders.LineStyle = 1
Selection.Borders.ColorIndex = 17
  For i = 9 To son
If Range("C" & i) = "" Then
Range("A" & i).EntireRow.Delete
End If
If Range("C" & i) <> Range("C" & i + 1) Then
Range("a" & i & ": R" & i).Select
With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
     Range("R9" & ": R" & son).Select
    With Selection.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
        End With
        Range("A9" & ": A" & son).Select
    With Selection.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
        End With
 End If
 Next i
 Range("C" & son + 1).Select
Application.ScreenUpdating = True
End Sub
 
Son düzenleme:
Merhaba ilgili kodu (kod Grörüntüle) kısmına yapıştıracağız galiba. Peki nasıl çalıştıracağız bu makroyu
 
Geliştirici menüsü var ise Visual Basic tıkla Dosyada ki sayfa isimleri görülür.Sayfa1(Sayfa1) gibi .Sayfa1(Sayfa1) çift tıkla ve yandaki beyaz alana kopyala sonra A9 tan itiberen yazılar yazarak deneyiniz.
 
Merhabalar efendim. A9 sütununa ben yazı yazarak değil, bu rapor zaten hazır programdan alıyorum.yani ben yazı yazmayacam.mesela ctrl+k dediğimde yada makroya bir resim ekleyip makroyu o resme atayıp resme tıkladığımızda her a9daki temsil.ıd değiştiğinde otomatik kenar ve çerçeve oluştursun.
YApmış olduğunuz kod yazdıkça çerçeveye alıyor, ama benim istediğim bu değil.
 
C9 göre düzenlendi deneyerek sonuçu bildiriniz.
 
Son düzenleme:
Kusura bakmayın.hazır raporu yapıştırdığımda kod çalıştı. Elinize sağlık. Peki burada bir değişiklik yapabilirmiyiz. Bu temsil ID A9 DA DEĞİLDE c9 da olursa nasıl birşey yapabiliriz.
 
Tekrar merhaba,
KOd normalde çalışıyor fakat filtre yaptığımda tarihi değiştirdiğimde otomatik güncellemiyor, bununla ilgili nasıl yardımcı olabşlir misiniz.
 
Merhaba
elimde ekteki gibi dosya var. bu dosyada resime tıkladığım zaman çerçeveleri çizgileri otomatik çiziyor ama burada da sütün A DAKİ BİLGİLERE GÖRE BAŞLIYOR.
bu kodu sutun C YE AYARLAYABİLİRMİİSNİZ.
 

Ekli dosyalar

C ye göre değiştirildi.Eski kodları silerek yeni konu kullanınız.
 
Merhaba çıtır. Yapmış olduğunuz kod çalışıyor. teşekkürler ama filtre yaptığımızda tarih değiştirdiğimizde çizgi ve çerçeveyi yeni verilere göre güncellemiyor.
 

Ekli dosyalar

muratkul' Alıntı:
Merhaba çıtır. Yapmış olduğunuz kod çalışıyor. teşekkürler ama filtre yaptığımızda tarih değiştirdiğimizde çizgi ve çerçeveyi yeni verilere göre güncellemiyor.
Genişletmek için tıkla ...
İsteğiniz.
Merhabalar,
Ekteki dosyada olduğu gibi her numara değiştiğinde aynı numaraları çerçeve içine almasını istiyorum.YArdımcı olabilirmisiniz.

Tarihlere veya diğer verilere göre çizgiler oluşmaz ,isteğiniz numaralara göre oluşması idi buna göre kodlar oluşturulmuştur.
 
Merhaba Çıtır,
Benim istemiş olduğum kodu yaptınız teşekkürler.
Bu kodu Makro olarak nasıl ayarlarız acaba.
 
Merhabalar,
kenarlık ve çizgi yerine her temsilcinin bulunduğu sütun ve satırları açık ve koyu dolgu rengi yapabilir.z. bunun için yardımcı olabilirmisiniz.
 
cerceve yerine renk isteğiniz.Kolay gelsin.
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [C9:C10000]) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
 ActiveWindow.DisplayGridlines = False
Dim i As Integer
son = Cells(65536, "C").End(3).Row
Range("A9").Interior.ColorIndex = 16
For i = 9 To son
Range("A9").Interior.ColorIndex = 16
ilk = Range("C" & i)
ilk1 = Range("C" & i + 1)
If ilk = ilk1 And ilk <> "" Then
Range("A" & i).Offset.Resize(1, 19).Interior.Color = Range("A" & i).Interior.Color
Range("A" & i + 1).Offset.Resize(1, 19).Interior.Color = Range("A" & i).Interior.Color
End If
If ilk <> ilk1 And ilk <> "" And Range("A" & i).Interior.ColorIndex = 16 Then
Range("A" & i + 1).Interior.ColorIndex = 24
Range("A" & i).Offset.Resize(1, 19).Interior.Color = Range("A" & i).Interior.Color
End If
If ilk <> ilk1 And ilk <> "" And Range("A" & i).Interior.ColorIndex = 24 Then
Range("A" & i + 1).Interior.ColorIndex = 16
Range("A" & i).Offset.Resize(1, 19).Interior.Color = Range("A" & i).Interior.Color
End If
Next i
Range("A" & son + 1).Interior.ColorIndex = xlNone
Application.ScreenUpdating = False
End Sub
 
bu makroya nasıl düğme yada resim ekleyeceğiz çıtır
 
Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...
Geri
Üst