Tự động tìm khoảng cách giữa các ô có màu (1 người xem)

Elx Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
toandiennuoc123

toandiennuoc123

Thành viên thường trực
Tham gia
7/3/12
Bài viết
239
Được thích
9
Chào tất cả các bạn ! Tôi có 1 bài tìm khoảng cách giữa các ô có màu, các bạn xem file đính kèm, xin cám ơn các bạn.
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
Đếm khoảng cách như thế nào hả bạn?
 
Upvote 0
toandiennuoc123 đã viết:
Chào tất cả các bạn ! Tôi có 1 bài tìm khoảng cách giữa các ô có màu, các bạn xem file đính kèm, xin cám ơn các bạn.
Nhấp chuột vào đây để mở rộng...
PHP: 
Sub Kycuc()
Dim item, Mem, Odau, Ocuoi, i, Vitri1, Vitri2
For Each item In Range("A5:AE100")
   If item.Interior.ColorIndex <> xlNone Then
      Mem = Mem + 1
      If Mem = 1 Then
         Odau = item.Value
         Vitri1 = item.Address(0, 0)
      End If
   Else
      If Mem = 1 Then i = i + 1
   End If
   If Mem = 2 Then
      Ocuoi = item.Value
      Vitri2 = item.Address(0, 0)
      Exit For
   End If
Next
MsgBox "Khoang cach la: " & i & vbLf & _
"Vi tri dau la: " & Vitri1 & vbLf & _
"Gia tri dau la: " & Odau & vbLf & _
"Vi tri cuoi la: " & Vitri2 & vbLf & _
"Gia tri cuoi la: " & Ocuoi
End Sub
 
Upvote 0
Cám ơn QuangHai , bạn có thể cho kết quả vào ô đã được chỉ định được không ? vì khi sử dụng bảng tính thì MsgBox nó biến mất nên không tiện sử dụng
 
Upvote 0
toandiennuoc123 đã viết:
Cám ơn QuangHai , bạn có thể cho kết quả vào ô đã được chỉ định được không ? vì khi sử dụng bảng tính thì MsgBox nó biến mất nên không tiện sử dụng
Nhấp chuột vào đây để mở rộng...

Mình nghĩ bạn nên tập sửa code đi.
Mọi thứ đã sẵn hết rồi, chỉ còn ráp vào thôi mà
Gán biến i, vitri1, vitri2, odau, ocuoi vào những nơi bạn muốn.
 
Upvote 0
@quanghai1969: cứ nghe hai từ "bài tập" là biết ngay loại bài dọn cỗ. Không có ai siêng mà tải code của bạn về sửa lại đâu.

Mã: 
Sub t()
Const ODAU = "A1"
Const OCUOI = "AE100"
Dim cll(1 To 2) As Range, c As Variant, num As Integer
For Each c In Range(ODAU, OCUOI)
    If c.Interior.ColorIndex <> xlNone Then
        num = num + 1
        Set cll(num) = c
    End If
    If num >= 2 Then Exit For
Next c
If num < 2 Then
    MsgBox "cha co du 2 o mau, khong tinh gi duoc ca"
Else
    num = Range(OCUOI).Column - Range(ODAU).Column + 1
    Range("ô cần chứa số ô").Value = num * (cll(2).Row - cll(1).Row) + cll(2).Column - cll(1).Column - 1
    Range("ô cần chứa địa chỉ 1").Value = cll(1).Address
    Range("ô cần chứa địa chỉ 2").Value = cll(2).Address
    Range("ô cần chứa trị 1").Value = cll(1).Value
    Range("ô cần chứa trị 2").Value = cll(2).Value
End If
Set cll(1) = Nothing
Set cll(2) = Nothing
End Sub
 
Upvote 0
VetMini đã viết:
@quanghai1969: cứ nghe hai từ "bài tập" là biết ngay loại bài dọn cỗ. Không có ai siêng mà tải code của bạn về sửa lại đâu.

Mã: 
Sub t()
Const ODAU = "A1"
Const OCUOI = "AE100"
Dim cll(1 To 2) As Range, c As Variant, num As Integer
For Each c In Range(ODAU, OCUOI)
    If c.Interior.ColorIndex <> xlNone Then
        num = num + 1
        Set cll(num) = c
    End If
    If num >= 2 Then Exit For
Next c
If num < 2 Then
    MsgBox "cha co du 2 o mau, khong tinh gi duoc ca"
Else
    num = Range(OCUOI).Column - Range(ODAU).Column + 1
    Range("ô cần chứa số ô").Value = num * (cll(2).Row - cll(1).Row) + cll(2).Column - cll(1).Column - 1
    Range("ô cần chứa địa chỉ 1").Value = cll(1).Address
    Range("ô cần chứa địa chỉ 2").Value = cll(2).Address
    Range("ô cần chứa trị 1").Value = cll(1).Value
    Range("ô cần chứa trị 2").Value = cll(2).Value
End If
Set cll(1) = Nothing
Set cll(2) = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Bài này sửa thế nào nếu có nhiều ô có màu ( giả sử trong a1:af100 có 50 ô có màu ) thì đếm như thế nào nhỉ ?
 
Upvote 0
toandiennuoc123 đã viết:
Bài này sửa thế nào nếu có nhiều ô có màu ( giả sử trong a1:af100 có 50 ô có màu ) thì đếm như thế nào nhỉ ?
Nhấp chuột vào đây để mở rộng...

Tôi biết thể nào bạn cũng hỏi chỗ này nên code trên đã chuẩn bị sẵn.
Sửa:
Trong vòng lặp thu thập dữ liệu: những con số 2 có ý nghĩa là giới han sửa lại thành số tối đa
Trong code ghi kết quả: dùng vòng lặp để ghi, những son số 1 và 2 có ý nghĩa thứ tự thì sử thành i và i+1
 
Upvote 0
VetMini đã viết:
Tôi biết thể nào bạn cũng hỏi chỗ này nên code trên đã chuẩn bị sẵn.
Sửa:
Trong vòng lặp thu thập dữ liệu: những con số 2 có ý nghĩa là giới han sửa lại thành số tối đa
Trong code ghi kết quả: dùng vòng lặp để ghi, những son số 1 và 2 có ý nghĩa thứ tự thì sử thành i và i+1
Nhấp chuột vào đây để mở rộng...
Loay hoay mãi không được, bạn sửa giúp tôi nhé !
Sub t1()
Const ODAU = "A1"
Const OCUOI = "AE100"
Dim cll(1 To 2976) As Range, c As Variant, num As Integer
For Each c In Range(ODAU, OCUOI)
If c.Interior.ColorIndex <> xlNone Then
num = num + i
Set cll(num) = c
End If
If num >= 2976 Then Exit For
Next c
If num < 2976 Then
MsgBox "cha co du 2 o mau, khong tinh gi duoc ca"
Else
num = Range(OCUOI).Column - Range(ODAU).Column + i
Range("AG1").Value = num * (cll(i + 1).Row - cll(i).Row) + cll(i + 1).Column - cll(i).Column - i
Range("AJ1").Value = cll(i).Address
Range("AJ2").Value = cll(i + 1).Address
Range("AK1").Value = cll(i).Value
Range("AK2").Value = cll(i + 1).Value
End If
Set cll(i) = Nothing
Set cll(i + 1) = Nothing
End Sub

Không biết sai ở đâu ?........ẹc.......ẹc
 
Upvote 0
Mã: 
Sub t()
Const ODAU = "A1"
Const OCUOI = "AE100"
Dim cll(1 To 1000) As Range, c As Variant, num As Integer
For Each c In Range(ODAU, OCUOI)
    If c.Interior.ColorIndex <> xlNone Then
        num = num + 1
        Set cll(num) = c
    End If
Next c
If num < 2 Then
    MsgBox "co duoi 2 o mau, khong tinh gi duoc ca"
Else
    For i = 1 To num - 1
        Range("AG1").Offset(1, i).Value = (Range(OCUOI).Column - Range(ODAU).Column + 1) * (cll(i + 1).Row - cll(i).Row) _
                    + cll(i + 1).Column - cll(i).Column - 1
        Range("AG1").Offset(2, i).Value = cll(i).Address
        Range("AG1").Offset(3, i).Value = cll(i + 1).Address
        Range("AG1").Offset(4, i).Value = cll(i).Value
        Range("AG1").Offset(5, i).Value = cll(i + 1).Value
    Next i
End If
End Sub
 
Upvote 0
VetMini đã viết:
Mã: 
Sub t()
Const ODAU = "A1"
Const OCUOI = "AE100"
Dim cll(1 To 1000) As Range, c As Variant, num As Integer
For Each c In Range(ODAU, OCUOI)
    If c.Interior.ColorIndex <> xlNone Then
        num = num + 1
        Set cll(num) = c
    End If
Next c
If num < 2 Then
    MsgBox "co duoi 2 o mau, khong tinh gi duoc ca"
Else
    For i = 1 To num - 1
        Range("AG1").Offset(1, i).Value = (Range(OCUOI).Column - Range(ODAU).Column + 1) * (cll(i + 1).Row - cll(i).Row) _
                    + cll(i + 1).Column - cll(i).Column - 1
        Range("AG1").Offset(2, i).Value = cll(i).Address
        Range("AG1").Offset(3, i).Value = cll(i + 1).Address
        Range("AG1").Offset(4, i).Value = cll(i).Value
        Range("AG1").Offset(5, i).Value = cll(i + 1).Value
    Next i
End If
End Sub
Nhấp chuột vào đây để mở rộng...
Không lường được hết vấn đề nên đặt câu hỏi không chuẩn, mong bạn thông cảm. Code này nó không nhận màu trong CF...........Rất mong được sự giúp đỡ của bạn !
 
Upvote 0
toandiennuoc123 đã viết:
Không lường được hết vấn đề nên đặt câu hỏi không chuẩn, mong bạn thông cảm. Code này nó không nhận màu trong CF...........Rất mong được sự giúp đỡ của bạn !
Nhấp chuột vào đây để mở rộng...
Thử code này
PHP: 
Sub Kycuc()
Dim item, Mem, Odau, Ocuoi, i, Vitri1, Vitri2
For Each item In Range("A5:AE100")
   If item.DisplayFormat.Interior.ColorIndex <> xlNone Then
      Mem = Mem + 1
      If Mem = 1 Then
         Odau = item.Value
         Vitri1 = item.Address(0, 0)
      End If
   Else
      If Mem = 1 Then i = i + 1
   End If
   If Mem = 2 Then
      Ocuoi = item.Value
      Vitri2 = item.Address(0, 0)
      Exit For
   End If
Next
[AG1].Value = i
[AJ1].Value = Vitri1
[AK1].Value = Odau
[AJ2].Value = Vitri2
[AK2].Value = Ocuoi
End Sub
 
Upvote 0
Trong Excel 2010 có cách để nhận CF. 2007 trở về trước thì phải thêm code rất dài dòng.
Tôi vốn không chuyên về màu (*), bạn nên chờ người khác giúp vậy.

(*) môi trường nơi tôi làm việc vốn nhạy cảm với màu cho nên tôi ít khi để ý tới vấn đề này.
Tôi tiếp xúc với nhiều thành phần. Tuy tỷ lệ mù màu không nhiều, nhưng nếu đưa cho họ một file có màu thì rất khó chịu, phải lựa những màu thế nào cho họ có thể phân biệt được. Vì vậy tôi chỉ chú trọng cách trình bày lô gic vị trí dữ liệu thay vì dùng màu mè.
Nói thật, đọc ở diễn đàn này có nhiều files dùng màu như trang trí tuồng cải lương, nhiều ô màu xậm đến độ không đọc chữ nổi, đem ra ngoài sẽ bị sổ toẹt hết.

Bổ sung: pót xong mới thấy bài #14. Như tôi đã nêu trên, nếu bạn dùng Exxcel 2010 thì có thể dùng code bài #14 này để nhận màu dễ dàng.
 
Lần chỉnh sửa cuối:
Upvote 0
quanghai1969 đã viết:
Thử code này
PHP: 
Sub Kycuc()
Dim item, Mem, Odau, Ocuoi, i, Vitri1, Vitri2
For Each item In Range("A5:AE100")
   If item.DisplayFormat.Interior.ColorIndex <> xlNone Then
      Mem = Mem + 1
      If Mem = 1 Then
         Odau = item.Value
         Vitri1 = item.Address(0, 0)
      End If
   Else
      If Mem = 1 Then i = i + 1
   End If
   If Mem = 2 Then
      Ocuoi = item.Value
      Vitri2 = item.Address(0, 0)
      Exit For
   End If
Next
[AG1].Value = i
[AJ1].Value = Vitri1
[AK1].Value = Odau
[AJ2].Value = Vitri2
[AK2].Value = Ocuoi
End Sub
Nhấp chuột vào đây để mở rộng...
Về màu thì OK rồi nhưng nó tìm được mỗi một vị trí, mà cái mình cần là n vị trí " Dim cll(1 To 1000) As Range ". Mong QuangHai giúp đỡ tiếp.......Chân thành cám ơn
 
Upvote 0
VetMini đã viết:
Trong Excel 2010 có cách để nhận CF. 2007 trở về trước thì phải thêm code rất dài dòng.
Tôi vốn không chuyên về màu (*), bạn nên chờ người khác giúp vậy.

(*) môi trường nơi tôi làm việc vốn nhạy cảm với màu cho nên tôi ít khi để ý tới vấn đề này.
Tôi tiếp xúc với nhiều thành phần. Tuy tỷ lệ mù màu không nhiều, nhưng nếu đưa cho họ một file có màu thì rất khó chịu, phải lựa những màu thế nào cho họ có thể phân biệt được. Vì vậy tôi chỉ chú trọng cách trình bày lô gic vị trí dữ liệu thay vì dùng màu mè.
Nói thật, đọc ở diễn đàn này có nhiều files dùng màu như trang trí tuồng cải lương, nhiều ô màu xậm đến độ không đọc chữ nổi, đem ra ngoài sẽ bị sổ toẹt hết.

Bổ sung: pót xong mới thấy bài #14. Như tôi đã nêu trên, nếu bạn dùng Exxcel 2010 thì có thể dùng code bài #14 này để nhận màu dễ dàng.
Nhấp chuột vào đây để mở rộng...
Cám ơn bạn Vetmini, thực ra tôi cũng không muốn màu mè nhưng bài này là tìm khoảng cách giữa 2 ô có màu (CF) lọc trùng mà. Rất cám ơn bạn đã nhiệt tình giúp đỡ
 
Upvote 0
Nếu dùng 2010 thì sửa Interior.ColorIndex thành DisplayFormat.Interior.ColorIndex
chỉ vậy thôi. Tuy nhiên, phải cẩn thận là code này chỉ chạy với VBA, nếu dùng cho hàm người dùng (UDF) thì sẽ bị lỗi.
 
Upvote 0
VetMini đã viết:
Nếu dùng 2010 thì sửa Interior.ColorIndex thành DisplayFormat.Interior.ColorIndex
chỉ vậy thôi. Tuy nhiên, phải cẩn thận là code này chỉ chạy với VBA, nếu dùng cho hàm người dùng (UDF) thì sẽ bị lỗi.
Nhấp chuột vào đây để mở rộng...
Cám ơn bạn. Phải nói là thành công 99% rồi, nhưng "lại nhưng" còn 1 vấn đề nữa là để kết quả theo hàng ngang thì nó bị tràn bảng tính ( Office 2013 --> lưu file 97-2003) nó chỉ có 256 cột thôi, bây giờ tôi muốn chuyển nó thành hàng dọc (BC109:BC65000). bạn giúp tôi nhé !? Chân thành cám ơn
 
Upvote 0
Mã: 
dim ghi as range
set ghi = Range("B109")
    For i = 1 To num - 1
        ghi.Offset(0).Value = (Range(OCUOI).Column - Range(ODAU).Column + 1) * (cll(i + 1).Row - cll(i).Row) _
                    + cll(i + 1).Column - cll(i).Column - 1
        ghi.Offset(1).Value = cll(i).Address
        ghi.Offset(2).Value = cll(i + 1).Address
        ghi.Offset(3).Value = cll(i).Value
        ghi.Offset(4).Value = cll(i + 1).Value
        set ghi = ghi.Offset(5)
    Next i
set ghi = nothing
 
Lần chỉnh sửa cuối:
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

Bài viết mới nhất

L
Tính thời gian làm việc thực tế (1 người xem)
Trả lời
66
Đọc
14K
YenTon
Y
H
Chia sẻ file in Phiếu điều tra PCGD (2 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
13
Đọc
630
Phuong7686
P
GPE-Trợ Lý
  • Dán lên cao
[KHẨN] HƯỚNG VỀ ĐỒNG BÀO CHỊU ẢNH HƯỞNG CỦA BÃO YAGI - BẢO YÊN, LÀO CAI (1 người xem)
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
91
Đọc
14K
SA_DQ
SA_DQ
SA_DQ
Copilot bình luận về một ván cờ vua
    • Thích
Trả lời
6
Đọc
409
SA_DQ
SA_DQ
92nguyenthanh
  • Question Question
Vba cho file nhập xuất kho
Trả lời
4
Đọc
110
HUONGHCKT
H
C
Fix lỗi Application.InputBox Type:=8
    • Cười
Trả lời
25
Đọc
618
ptm0412
ptm0412
GPE-Trợ Lý
[GPE] TALK SHOW 08: GIẢI QUYẾT VẤN ĐỀ TỐI ƯU HÓA TRONG EXCEL VỚI CÔNG CỤ SOLVER
    • Thích
    • Cảm ơn
Trả lời
4
Đọc
3K
DuongLeHung
D
Gà Công Nghệ
Chế độ chính sách cho giáo viên mầm non giữ trẻ khuyết tật (1 người xem)
Trả lời
1
Đọc
58
vanle33
vanle33
huuthang_bd
Add-in DeleteVirusMacro - Xóa và ngăn chặn virus macro
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
56
Đọc
22K
dunghtgiga
dunghtgiga
L
  • Question Question
Viết code tìm kiếm các file trong Folder
Trả lời
40
Đọc
12K
lan nguyen0987
L
P
Hyperlink_Cách chuyển cả thư mục và file tổng hợp sang máy khác không bị lỗi
Trả lời
5
Đọc
109
phongvanvu
P
HeSanbi
Tiện ích Web: Tự động nhấn nút "Bỏ qua" quảng cáo Youtube
    • Thích
    • Yêu thích
Trả lời
14
Đọc
1K
ongke0711
ongke0711
ptm0412
Quá tin tưởng vào AI các thể loại
    • Cười
Trả lời
4
Đọc
218
Maika8008
Maika8008
A
  • Question Question
Không tìm được lỗi code
Trả lời
6
Đọc
159
ptm0412
ptm0412
W
Tham chiếu theo chuỗi ký tự
Trả lời
8
Đọc
315
dungpham01
D
tritv.dad
Lấy dữ liệu từ folder các tờ khai thông quan để theo dõi hiệu suất công việc.
Trả lời
8
Đọc
287
BlueSphere
B
GPE-Trợ Lý
MỪNG NGÀY NHÀ GIÁO VIỆT NAM 20/11 (1 người xem)
    • Thích
Trả lời
0
Đọc
3K
GPE-Trợ Lý
GPE-Trợ Lý
SA_DQ
Xin chúc mừng các thầy cô giáo trên cộng đồng nhân 20/11
    • Thích
    • Yêu thích
Trả lời
1
Đọc
135
BuiQuangThuan
B
M
chuyển đổi số thành chữ
Trả lời
15
Đọc
371
dungpham01
D
V
Lỗi copy sheet: the name already exists.
Trả lời
7
Đọc
702
nghiabros
N
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom