định Dạng Màu Nền

[ngvanho]

Tôi Có Nhiều ô A1,a2,a3....b1,b2,b3... Tôi Gán D50=a1,d51=a2,d52=a3.... Làm Thế Nào để Khi Tôi Tô Màu Nền A1,a2,a3 Thi Cac ô D50,d51,d52 đổi Màu Nền Theo.xin Cám ơn Các Anh Chị Trước. Hồ .

 

[SA_DQ]

Nếu chấp nhận sau khi tô màu phải bấm đúp vô ô, thì đây:

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
 On Error Resume Next
 Dim Rng As Range, bColor As Byte, Clls As Range
 Dim Value_ As Variant
    
 bColor = Target.Interior.ColorIndex
 If bColor > 2 Then
    Value_ = Target.Value
    Set Rng = UsedRange
    For Each Clls In Rng
        If Clls.Value = Value_ Then _
            Clls.Interior.ColorIndex = bColor
    Next Clls
 End If
End Sub

 

[anhtuan1066]

Đại ca ơi, hình như nó tô màu chưa đúng thì phải... Theo em hiểu thì tác giã muốn Cell D50, D51 và D52 sẽ tô màu giống như cell A1, A2 và A3
Cái này nó tô 1 phát từ A1 đến D12 cùng 1 màu...

Tôi thấy như vầy: Đàng nào thì bạn cũng đang gán D50 = A1, D51 = A2 vân vân... Vậy tôi có cách này tuy ko phải là hay ho gì cho lắm:
1> Đầu tiên đặt name cho vùng A1 đến .. bao nhiêu đó là ARR1, đặt name cho vùng D50 đến... là ARR2
2> Tiếp theo dùng code sau:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect(Range("ARR1,ARR2"), Target) Is Nothing Then
     Range("ARR1").Copy Destination:=Range("ARR2")
  End If
End Sub

Khi bạn thay đổi giá trị và cã màu sắc ở vùng ARR1 thì chắc chắn vùng ARR2 cũng sẽ thay đổi tương tự
Xem file nhé!
ANH TUẤN

 

[ngvanho]

Tôi thấy như vầy: Đàng nào thì bạn cũng đang gán D50 = A1, D51 = A2 vân vân... Vậy tôi có cách này tuy ko phải là hay ho gì cho lắm:
1> Đầu tiên đặt name cho vùng A1 đến .. bao nhiêu đó là ARR1, đặt name cho vùng D50 đến... là ARR2
2> Tiếp theo dùng code sau:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Range("ARR1,ARR2"), Target) Is Nothing Then
Range("ARR1").Copy Destination:=Range("ARR2")
End If
End Sub

Khi bạn thay đổi giá trị và cã màu sắc ở vùng ARR1 thì chắc chắn vùng ARR2 cũng sẽ thay đổi tương tự
Xem file nhé!
ANH TUẤN

CÁM ƠN CẢ 2 ANH SA_DQ VÀ ANH TUẤN NHÉ.QUA COS CỦA 2 ANH TÔI ĐÃ LÀM ĐƯỢC RỒI.CỦA ANH SA_DQ LÀ CHỈ CẦN ĐỔI MÀU Ô PHỤ THUỘC,CÒN CỦA ANH TUẤN THI ĐỔI MÀU NGHIÊM NGẶT HƠN ,CHÍNH XÁC MÀU THEO Ô NGUỒN . CÁM ƠN NHIỀU NHÉ.NĂM MỚI CHÚC GIA ĐÌNH 2 ANH VẠN SỰ NHƯ Ý.PHÁT TÀI,PHÁT LỘC.MỌI ĐỀU MAY MẮN ĐỀU ĐẾN VỚI 2 ANH VÀ GIA ĐÌNH.

 

[voda]

Thêm một cách nữa cho vui những ngày đầu xuân:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Dim Rng As Range, bColor As Byte, Clls As Range
Dim ii As String, tt As String
      ii = Target.Formula
      Set Rng = UsedRange
    For Each Clls In Rng
        bColor = Clls.Interior.ColorIndex
        tt = Clls.Address
        tt = "=" & Replace(tt, "$", "")
        If tt = ii Then
            Target.Interior.ColorIndex = bColor
        End If
        Next Clls
End Sub

 

[ngvanho]

Option Explicit
 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error Resume Next
Dim Rng As Range, bColor As Byte, Clls As Range
Dim Value_ As Variant
 
bColor = Target.Interior.ColorIndex
If bColor > 2 Then
Value_ = Target.Value
Set Rng = UsedRange
For Each Clls In Rng
If Clls.Value = Value_ Then _
Clls.Interior.ColorIndex = bColor
Next Clls
End If
End Sub

ANH SA_DQ ! NẾU NHƯ THEO CÁCH CỦA ANH .MÌNH CÓ CÁCH NÀO SAU KHI TÔ MÀU NHỮNG Ô NGUỒN , MÌNH CHỈ NHẤP ĐÚP 1 LẦNHAY CHẠY 1 MACRO NÀO ĐÓ ĐỂ CÁC Ô ĐÍCH ĐỔI MÀU NỀN 1 LẦN CHO TIỆN;CHỨ CÓ CỞ 500 Ô MÀ NHẤP ĐÚP 500 LẦN CHẮC ...CHẾT QUÁ.TÔI CHỌN CÁCH CỦA ANH VÌ VỊ TRÍ Ô ĐÍCH VẪN ĐƯỢC TÔN TRỌNG THEO CÁCH GÁN BAN ĐẦU.

 

[ngvanho]

Định Dạng Màu Nền

Thêm một cách nữa cho vui những ngày đầu xuân:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Dim Rng As Range, bColor As Byte, Clls As Range
Dim ii As String, tt As String
      ii = Target.Formula
      Set Rng = UsedRange
    For Each Clls In Rng
        bColor = Clls.Interior.ColorIndex
        tt = Clls.Address
        tt = "=" & Replace(tt, "$", "")
        If tt = ii Then
            Target.Interior.ColorIndex = bColor
        End If
        Next Clls
End Sub

BẠN VODA À!Ở ĐÂY CÁC Ô ĐÍCH ĐẢ ĐƯỢC GÁN SẲN BẰNG CÁC Ô NGUỒN RỒI VÀ CÓ CẢ HÀNG TRĂM Ô NHƯ VẬY. YÊU CẦU LÀ KHI TA TÔ MÀU NỀN Ô NGUỒN THÌ CÁC Ô ĐÍCH ĐỔI MÀU THEO TỨC THÌ CHỨ CÒN DOUBLE CLICK CẢ TRĂM LẦN THÌ KHÔNG TIỆN.

 

[anhtuan1066]

Bạn có thể đưa file thật cũa bạn lên dc ko? Tôi sẽ làm 1 nhát chính xác luôn cho bạn...
Trong trường hợp này mà dùng Change hoặc BeforeDoubleClick thì e rằng ko ổn... Cũng như bạn nói, đổi màu xong click 1 cái nó hoạt động liền, đó là SelectionChange... theo tôi cách ấy tạm ổn nhất... Bạn đưa file lên đi, đở mất công mọi người giã lập, có khi lại ko đúng ý đồ cũa bạn...
Mến
ANH TUẤN

 

[ngvanho]

để Mình Tải File Nhé.

 

[anhtuan1066]

Ai chà... dử liệu cũa bạn trông.. ngộ quá ha.. chẳng hiểu nó là gì cã...
Tôi cũng cố gắng làm cho bạn đây...
1> Đầu tiên tôi đặt name cho từng vùng màu xanh lá là: ARR1, ARR2.. đến ARR12
2> Tiếp theo dùng code:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Application.ScreenUpdating = False
   If Target.Address = "$A$1" Then
   For I = 1 To 12
     For Each Clls In Range("ARR" & I)
       If Clls.Value <> "" Then
          K = K + 1
          Clls.Copy Destination:=Cells(K + 56, 5)
        End If
      Next
      K = K + 1
   Next I
   End If
End Sub

Sau khi tô màu xong, bạn chỉ cần nhấp vào cell A1 thì code sẽ chạy...
Tôi copy xuống Cell E57 trở xuống đễ bạn tiện so sánh, nếu thấy dc thì hãy xóa các cell từ D57 trở xuống là dc rồi... sẽ ko cần công thức nữa
Mến
ANH TUẤN

 

[SA_DQ]

Dùng đoạn mã này vậy:

Bạn gán cho macro này 1 tổ hợp phím, VD CTRL+SHIFT+C
Chọn vùng ô có màu nền & bấm tổ hợp phím dấu iêu của bạn;

Option Explicit
Sub ColorRangeS()
 On Error Resume Next
Dim Rng As Range, Clls As Range, UsedRng As Range, Cll0 As Range
Dim Value_, bColor As Integer

Set Rng = Selection:        Set UsedRng = ActiveSheet.UsedRange
Application.ScreenUpdating = False
For Each Clls In Rng
    bColor = Clls.Interior.ColorIndex
    If bColor > 2 Then
        Value_ = Clls.Value
        
        For Each Cll0 In UsedRng
            If Cll0.Value = Value_ Then _
                Cll0.Interior.ColorIndex = bColor
        Next Cll0
    End If
 Next Clls
End Sub

Chúc Vui!!

 

[anhtuan1066]

Công nhận code cũa anh SA_DQ chạy cực nhanh... nhưng quã thật nó cao cấp quá, tôi nhìn hoài vẫn ko tài nào hiểu dc... Chắc phải luyện thêm vài năm công thức nữa... Hi... hi...
Cãm ơn anh!
ANH TUẤN

 

[voda]

Các bạn thử code này xem sao:

Sub doimau()
On Error Resume Next
Dim Rng As Range, bColor As Byte, Clls As Range
Dim tt As String
Set Rng = ActiveSheet.UsedRange
      For Each Clls In Rng
          tt = Clls.Formula
            If tt <> "" Then
                bColor = Range(tt).Interior.ColorIndex
                Clls.Interior.ColorIndex = bColor
                bColor = 0
            End If
      Next Clls
End Sub

 

[ngvanho]

Ai chà... dử liệu cũa bạn trông.. ngộ quá ha.. chẳng hiểu nó là gì cã...
Tôi cũng cố gắng làm cho bạn đây...
1> Đầu tiên tôi đặt name cho từng vùng màu xanh lá là: ARR1, ARR2.. đến ARR12
2> Tiếp theo dùng code:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.ScreenUpdating = False
If Target.Address = "$A$1" Then
For I = 1 To 12
For Each Clls In Range("ARR" & I)
If Clls.Value <> "" Then
K = K + 1
Clls.Copy Destination:=Cells(K + 56, 5)
End If
Next
K = K + 1
Next I
End If
End Sub

Sau khi tô màu xong, bạn chỉ cần nhấp vào cell A1 thì code sẽ chạy...
Tôi copy xuống Cell E57 trở xuống đễ bạn tiện so sánh, nếu thấy dc thì hãy xóa các cell từ D57 trở xuống là dc rồi... sẽ ko cần công thức nữa
Mến
ANH TUẤN

THẬT TUYỆT VỜI!CÁM ƠN ANH TUẤN RẤT NHIỀU.SAU KHI BỎ CÔNG THỨC GÁN MÌNH SẺ PHÁT TRIỂN THÊM VÀI CÁI NỮA.PHẦN QUAN TRỌNG NHẤT NẰM Ở CHỔ ANH TUẤN ĐÃ LÀM GIÚP MÌNH.CÁM ƠN RẤT NHIỀU.