إختيار مجموعة خلايا بناء علي لون الخط

[محمد طاهر عرفه]

مرفق ملف به عدد 2 ماكرو

الاول يسألك عن رقم اللون ، ثم يختار الخلايا التي بها لون الخط المناظر

و الثاني

يعرض لك ألوان الخطوط و ارقامها بدءا من الخلية الفعالة

Sub list_Cashes()


  Dim fs, S, A

    Set fs = CreateObject("Scripting.FileSystemObject")

    Set A = fs.CreateTextFile("c:\" & "temp.txt", True)

   

    A.writeline "Pivots in File named : " & ActiveWorkbook.FullName & " : "

    A.writeline

    A.writeline "*********** Prepared By Mohamed Taher *****************"

    A.writeline



 For i = 1 To ActiveWorkbook.PivotCaches.Count

 Dim tmpLine As String

  

  tmpLine = "Pivot Cash no. " & i & " : " & ActiveWorkbook.PivotCaches(i).SourceData

  A.writeline (tmpLine)

   

 Next i

    


    A.Close

    

    Dim x

    x = Shell("notepad.exe c:\temp.txt", 1)

    

    


End Sub

Sub list_RefreshonopenValue()


'Open "c:\temp.txt" For Output As #1

 'Lineinput ,#1 "koko"

 '  Close #1

  Dim fs, S, A

    Set fs = CreateObject("Scripting.FileSystemObject")

    Set A = fs.CreateTextFile("c:\" & "temp.txt", True)

   

    A.writeline "Pivots in File named : " & ActiveWorkbook.FullName & " : "

    A.writeline

    A.writeline "*********** Prepared By Mohamed Taher *****************"

    A.writeline



 For i = 1 To ActiveWorkbook.PivotCaches.Count



Dim tmpLine As String

  

  tmpLine = "Pivot Cash no. " & i & " refresh on open status : " & ActiveWorkbook.PivotCaches(i).RefreshOnFileOpen

  A.writeline (tmpLine)

   

 Next i

    


    A.Close

    

    Dim x

    x = Shell("notepad.exe c:\temp.txt", 1)

    

    


End Sub

Sub refresh()


    For i = 1 To ActiveWorkbook.PivotCaches.Count

     ActiveWorkbook.PivotCaches(i).refresh

    Next i


End Sub


Sub List_PivSources_PerSheet()


 Dim fs, S, A

    Set fs = CreateObject("Scripting.FileSystemObject")

    Set A = fs.CreateTextFile("c:\" & "temp.txt", True)

    A.writeline "Pivots per Sheet - in File named : " & ActiveWorkbook.FullName & " : "

    A.writeline

    A.writeline "*********** Prepared By Mohamed Taher *****************"

    A.writeline

    

For j = 1 To ActiveWorkbook.Worksheets.Count

    A.writeline

    A.writeline "Sheet named : " & ActiveWorkbook.Worksheets(j).Name

    A.writeline "----------"

  For k = 1 To ActiveWorkbook.Worksheets(j).PivotTables.Count

      Dim tmpLine As String

      tmpLine = "source of pivot no. " & j & " : " & ActiveWorkbook.Worksheets(j).PivotTables(k).SourceData

      A.writeline (tmpLine)

  Next k

Next j


    A.Close

    

    Dim x

    x = Shell("notepad.exe c:\temp.txt", 1)

    

    


'ActiveWorkbook.Worksheets("Sheet3").PivotTables(1) _

    .PivotFields("Year").Orientation = xlRowField

End Sub



Sub Do_RefreshonOpen()

'True if the PivotTable cache or query table is automatically updated each time the workbook is opened


'For Each pc In ActiveWorkbook.PivotCaches

'    pc.RefreshOnFileOpen = True

'Next


 For i = 1 To ActiveWorkbook.PivotCaches.Count

   ActiveWorkbook.PivotCaches(i).RefreshOnFileOpen = True

 Next i


End Sub


Sub No_RefreshonOpen()

'True if the PivotTable cache or query table is automatically updated each time the workbook is opened


'For Each pc In ActiveWorkbook.PivotCaches

'    pc.RefreshOnFileOpen = False

'Next


 For i = 1 To ActiveWorkbook.PivotCaches.Count

   ActiveWorkbook.PivotCaches(i).RefreshOnFileOpen = False

 Next i



End Sub


Sub Change_PivotCashes_RangeName()


 Dim fs, S, A

    Set fs = CreateObject("Scripting.FileSystemObject")

    Set A = fs.CreateTextFile("c:\" & "temp.txt", True)

    A.writeline "Change Pivot Sources per Sheet - in File named : " & ActiveWorkbook.FullName & " : "

    A.writeline

    A.writeline "*********** Prepared By Mohamed Taher *****************"

    A.writeline

    

    

Dim x As String

x = InputBox("PLease enter the Pivot Source Range Name", "Range name selection for Pivots", "SalesVillas")


For j = 1 To ActiveWorkbook.Worksheets.Count

    A.writeline

    A.writeline "Sheet named : " & ActiveWorkbook.Worksheets(j).Name

    A.writeline "================"

For k = 1 To ActiveWorkbook.Worksheets(j).PivotTables.Count

On Error GoTo errsub


 Dim y As String

 y = ActiveWorkbook.Worksheets(j).PivotTables(k).SourceData

 A.writeline "Before : " & y


     ActiveWorkbook.Worksheets(j).PivotTables(k).SourceData = Trim(x)

 A.writeline "After : " & Trim(x)

        


Next k

Next j


    A.Close

    

    Dim z

    z = Shell("notepad.exe c:\temp.txt", 1)


        Exit Sub

errsub:

        MsgBox Str(Err.Number) + Err.Description + "Action is cancelled"

        'return original source

        ActiveWorkbook.Worksheets(j).PivotTables(k).SourceData = y

        Exit Sub


End Sub

SelectByFontColor.rar