• DİKKAT

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

Özet Tablo renk

  • Konbuyu başlatan Konbuyu başlatan FERAZ
  • Başlangıç tarihi Başlangıç tarihi
FERAZ

FERAZ

Katılım
5 Kasım 2006
Mesajlar
603
Excel Vers. ve Dili
TÜRKCE Excel 2021 32bit
Merhaba.
Ekteki dosyada A sütununda yeşil ve kırmızı renkler var.Benim sorum bu renkleri B sütununa uygulamak.
Yani A daki kırmızı renk B dede olacak.Yeşilde aynen olcak.
Birde A sütununa veri girilmesi nası engellenir sayfa koruması felan olmadan.
B sütununda değişmiyor zaten.


Dosya
http://www.dosya.tc/server14/gujprn/OzetTablooo.rar.html

Resim
http://hizliresim.info/i/BXWV
PHP: 
Private Sub CommandButton1_Click()


  Dim act As Worksheet, syf As Worksheet
    
    On Error Resume Next
    
    Set syf = Sheets("Pivot")
    Set act = ActiveSheet
    pivot = "PivotTable1"
    
    say = 0
    
    For i = 1 To Worksheets.Count
        If Sheets(i).Name = "Pivot" Then
        say = 1
        Exit For
        End If
        
    Next
    
    If say = 0 Then
    Sheets.Add , Sheets("Deneme"): ActiveSheet.Name = "Pivot"
    End If
    
    
    Application.ScreenUpdating = False
    Sheets("Pivot").Select
    
    Sheets("Pivot").Cells.Clear
    
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
    "Deneme!R1C1:R10000C4", Version:=6).CreatePivotTable TableDestination:= _
    "Pivot!R3C1", TableName:="PivotTable1", DefaultVersion:=6
    
    
    ActiveSheet.PivotTables(pivot).RepeatAllLabels xlRepeatLabels
    
    With ActiveSheet.PivotTables(pivot).PivotFields("AÇIKLAMA")
        .Orientation = xlRowField
        .Position = 1
    End With
    
    With ActiveSheet.PivotTables(pivot).PivotFields("AÇIKLAMA-1")
        .Orientation = xlRowField
        .Position = 2
    End With
    
    With ActiveSheet.PivotTables(pivot).PivotFields("AÇIKLAMA-2")
        .Orientation = xlRowField
        .Position = 3
    End With
    
    ActiveSheet.PivotTables(pivot).PivotSelect "AÇIKLAMA[All]", xlLabelOnly + xlFirstRow, True
    Selection.Interior.ColorIndex = 3
    ActiveSheet.PivotTables(pivot).PivotSelect "'AÇIKLAMA-1'", xlLabelOnly + xlFirstRow, True
    Selection.Interior.ColorIndex = 4
    ActiveSheet.PivotTables(pivot).AddDataField ActiveSheet.PivotTables(pivot).PivotFields("XXX"), "Toplam XXX", xlSum
    ActiveSheet.PivotTables(pivot).PivotFields("Toplam XXX").NumberFormat = "#,##0.00"
    ActiveSheet.PivotTables(pivot).PivotFields("AÇIKLAMA").ShowDetail = True
    ActiveSheet.PivotTables(pivot).PivotFields("AÇIKLAMA-1").ShowDetail = False
    ActiveSheet.[A1].Select
    
    
    Application.ScreenUpdating = True
    
    Set syf = Nothing: Set acf = Nothing


End Sub
 
Teşekürler,renk olayı tamam.

PHP: 
 Selection.Offset(0, 1).Interior.ColorIndex = 3
bu kod nasıl aklıma gelmez :)

Birde asıl önemli olan A sütununa veri girişi engelleme olayı sayfa korumasız.
Bunu nasıl yapabiliriz?
 
Linkteki dosyada A sütununda Pivot Table alanına veri girişi yapamazsınız.Deneyin.
 
FERAZ' Alıntı:
Teşekürler,renk olayı tamam.

PHP: 
Selection.Offset(0, 1).Interior.ColorIndex = 3
bu kod nasıl aklıma gelmez :)

Birde asıl önemli olan A sütununa veri girişi engelleme olayı sayfa korumasız.
Bunu nasıl yapabiliriz?
Genişletmek için tıkla ...
autoopen makrosuna aşağıdaki kodu girerseniz yalnızca sayfa1 de B:Z aralığına veri girebilirsiniz.
Autoclose olayınada aralığı "" yaparsanız tekrar eski durumuna döner.:cool:

Kod: 
Dim sh As Worksheet
Set sh = Sheets("Sayfa1")
sh.ScrollArea = "sayfa1!B:Z"
 
Orion1' Alıntı:
autoopen makrosuna aşağıdaki kodu girerseniz yalnızca sayfa1 de B:Z aralığına veri girebilirsiniz.
Autoclose olayınada aralığı "" yaparsanız tekrar eski durumuna döner.:cool:

Kod: 
Dim sh As Worksheet
Set sh = Sheets("Sayfa1")
sh.ScrollArea = "sayfa1!B:Z"
Genişletmek için tıkla ...

Kodu deneyince yeşil alandaki + yerler genişletilmiyor.
 
Thisworkbook(BuÇalışmaKitabı)' da bulunan kod Pivot Table alanında Asütununa girişi engeller.
Kod: 
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Sh.Name = "Pivot" Then
son = Cells(Rows.Count, 1).End(3).Row
If Not Intersect(Target, Range("A3:A" & son)) Is Nothing Then
     Cells(Target.Row, Target.Column).Offset(0, 1).Select
End If
End If
End Sub
Eğer A sütununun tamamında girişi engellemek isterseniz.
Aşağıdaki gibi değiştirip kullanın.
Kod: 
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Sh.Name = "Pivot" Then
If Not Intersect(Target, Columns("A:A")) Is Nothing Then
     Cells(Target.Row, Target.Column).Offset(0, 1).Select
End If
End If
End Sub
 
Son düzenleme:
turist' Alıntı:
Thisworkbook(BuÇalışmaKitabı)' da bulunan kod Pivot Table alanında Asütununa girişi engeller.
Kod: 
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Sh.Name = "Pivot" Then
son = Cells(Rows.Count, 1).End(3).Row
If Not Intersect(Target, Range("A3:A" & son)) Is Nothing Then
     Cells(Target.Row, Target.Column).Offset(0, 1).Select
End If
End If
End Sub
Eğer A sütununun tamamında girişi engellemek isterseniz.
Aşağıdaki gibi değiştirip kullanın.
Kod: 
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Sh.Name = "Pivot" Then
If Not Intersect(Target, Columns("A:A")) Is Nothing Then
     Cells(Target.Row, Target.Column).Offset(0, 1).Select
End If
End If
End Sub
Genişletmek için tıkla ...

Bu kod A sütununa tıklayınca B sütununa geçiyor seçim.
Aslında bu kodları biliyorum.B dekini değiştirmeye uğraşınca mesaj kutusunda şu ifade çıkıyor.
''PivotTablenin bu bölümünü değiştiremiyoruz'' böyle birşey arıyorum aslında.
 
Veri doğrulama yapmayı bir deneyin isterseniz.:cool:
 
FERAZ' Alıntı:
Bu kod A sütununa tıklayınca B sütununa geçiyor seçim.
Aslında bu kodları biliyorum.B dekini değiştirmeye uğraşınca mesaj kutusunda şu ifade çıkıyor.
''PivotTablenin bu bölümünü değiştiremiyoruz'' böyle birşey arıyorum aslında.
Genişletmek için tıkla ...

Bu şekilde deneyin.
Kod: 
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Sh.Name = "Pivot" Then
son = Cells(Rows.Count, 1).End(3).Row
If Not Intersect(Target, Range("A3:A" & son)) Is Nothing Then
     MsgBox "PivotTablenin bu bölümünü değiştiremiyoruz. "
     Cells(Target.Row, Target.Column).Offset(0, 1).Select
End If
End If
End Sub
 
turist' Alıntı:
Bu şekilde deneyin.
Kod: 
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Sh.Name = "Pivot" Then
son = Cells(Rows.Count, 1).End(3).Row
If Not Intersect(Target, Range("A3:A" & son)) Is Nothing Then
     MsgBox "PivotTablenin bu bölümünü değiştiremiyoruz. "
     Cells(Target.Row, Target.Column).Offset(0, 1).Select
End If
End If
End Sub
Genişletmek için tıkla ...

Sağolun üstadım.Sayfa yada Çalışma kitabına kod yazmadan olmalı.Sanırım olmaz gibi.Yani ayarlardan felanda olabilirmi diye düşünmüştüm açıkçası.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst