Özet Tablo renk

[FERAZ]

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

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

 

[turist]

Dosyanız Linktedir.
İnceleyiniz.

 

[FERAZ]

Teşekürler,renk olayı tamam.

 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?

 

[turist]

Linkteki dosyada A sütununda Pivot Table alanına veri girişi yapamazsınız.Deneyin.

 

[Orion1]

Teşekürler,renk olayı tamam.

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?

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.

Dim sh As Worksheet
Set sh = Sheets("Sayfa1")
sh.ScrollArea = "sayfa1!B:Z"

 

[FERAZ]

Linkteki dosyada A sütununda Pivot Table alanına veri girişi yapamazsınız.Deneyin.

Denemiştim.Veri giriliyor tekrar deneyeyim.

 

[FERAZ]

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.

Dim sh As Worksheet
Set sh = Sheets("Sayfa1")
sh.ScrollArea = "sayfa1!B:Z"

Kodu deneyince yeşil alandaki + yerler genişletilmiyor.

 

[Orion1]

Kodu deneyince yeşil alandaki + yerler genişletilmiyor.

Manuel olarak sadece B:Z aralığına müdahale edilebilir.

 

[turist]

Thisworkbook(BuÇalışmaKitabı)' da bulunan kod Pivot Table alanında Asütununa girişi engeller.

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.

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

 

[FERAZ]

Thisworkbook(BuÇalışmaKitabı)' da bulunan kod Pivot Table alanında Asütununa girişi engeller.

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.

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

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.

 

[Orion1]

Veri doğrulama yapmayı bir deneyin isterseniz.

 

[FERAZ]

Veri doğrulama yapmayı bir deneyin isterseniz.

Denedim.PivotTable raporundaki hücrelere veri doğrulama uygulayamazsınız dedi alet

 

[turist]

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.

Bu şekilde deneyin.

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

 

[FERAZ]

Bu şekilde deneyin.

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

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ı.