在拉丁方里找满足条件的单元格

xihaihandsp · 发表于 2024-5-6 23:34

本帖最后由 xihaihandsp 于 2024-5-7 14:47 编辑

向各位老师求助，万分感谢！

taller · 发表于 2024-5-7 01:26

Option Explicit
Sub Demo()
Const DATA_RNG = "C3:G7"
Const START_CELL As String = "E3"
Dim iCol As Long: iCol = 24 ' Col X
Dim rngData As Range, colRes As New Collection, i As Long, aTxt, j As Long
Set rngData = Range(DATA_RNG)
FindCells 2, rngData, START_CELL, colRes
For i = 1 To colRes.Count
aTxt = Split(colRes(i), ",")
For j = 0 To UBound(aTxt)
Cells(1 + j, iCol) = aTxt(j)
Next
iCol = iCol + 1
Next
End Sub
Sub FindCells(iRow As Long, rngData As Range, sCells As String, ByRef colRes As Object)
Dim i As Long, j As Long, fullRng As Range, c As Range
Dim r As Range, sCellsList As String, RowCnt As Long
Set r = Range(sCells)
RowCnt = rngData.Rows.Count
For i = iRow To RowCnt
Set fullRng = Union(r.EntireRow, r.EntireColumn)
For Each c In rngData.Rows(i).Cells
If Intersect(c, fullRng) Is Nothing Then
Set r = Union(c, r)
sCellsList = sCells & "," & c.Address(0, 0)
If i = RowCnt Then
Debug.Print sCellsList
colRes.Add sCellsList
Else
FindCells i + 1, rngData, sCellsList, colRes
End If
End If
Next
Next
End Sub

复制代码

xihaihandsp · 发表于 2024-5-7 08:44

taller 发表于 2024-5-7 01:26

感谢老师帮助!!
我找的是5个不同列，不同行并且不同值的5个单元格，这个代码找见的是有值相同

xihaihandsp · 发表于 2024-5-7 08:47

taller 发表于 2024-5-7 01:26

老师，代码我如果把指定单元格换成E5的话，就完全错了

taller · 发表于 2024-5-7 09:29

本帖最后由 taller 于 2024-5-7 09:31 编辑

xihaihandsp 发表于 2024-5-7 08:44
感谢老师帮助!!
我找的是5个不同列，不同行并且不同值的5个单元格，这个代码找见的是有值相同

哪个组合是重复的？我测试代码没有问题

taller · 发表于 2024-5-7 09:43

' 更新代码
Option Explicit
Sub Demo()
Const DATA_RNG = "C3:G7"
Const START_CELL As String = "E5"
Dim iCol As Long: iCol = 24 ' Col X
Dim rngData As Range, colRes As New Collection, i As Long, aTxt, j As Long
Set rngData = Range(DATA_RNG)
FindCells 1, Range(START_CELL), rngData, START_CELL, colRes
For i = 1 To colRes.Count
aTxt = Split(colRes(i), ",")
For j = 0 To UBound(aTxt)
Cells(1 + j, iCol) = aTxt(j)
Next
iCol = iCol + 1
Next
End Sub
Sub FindCells(iRow As Long, firstCell As Range, rngData As Range, sCells As String, ByRef colRes As Object)
Dim i As Long, j As Long, fullRng As Range, c As Range
Dim r As Range, sCellsList As String, RowCnt As Long
Set r = Range(sCells)
RowCnt = rngData.Rows.Count
For i = iRow To RowCnt
If i + rngData.Row - 1 <> firstCell.Row Then
Set fullRng = Union(r.EntireRow, r.EntireColumn)
For Each c In rngData.Rows(i).Cells
If c.Column <> firstCell.Column Then
If Intersect(c, fullRng) Is Nothing Then
Set r = Union(c, r)
sCellsList = sCells & "," & c.Address(0, 0)
If i = RowCnt Then
Debug.Print sCellsList
colRes.Add sCellsList
Else
FindCells i + 1, firstCell, rngData, sCellsList, colRes
End If
End If
End If
Next
End If
Next
End Sub

复制代码

ooluckydog · 发表于 2024-5-7 13:55

xihaihandsp · 发表于 2024-5-7 14:30

ooluckydog 发表于 2024-5-7 13:55

谢谢老师，谢谢您帮助！！！！！！！！！

xihaihandsp · 发表于 2024-5-7 14:58

ooluckydog 发表于 2024-5-7 13:55

result(1, 1) = d(4) & 4  'F4单元格地址
brr(1, 1) = 5          'F4单元格值
For i = 1 To UBound(arr)
      status(i, 4) = True  'F4列状态设置为True，表示不能被选择
Next

老师，我把D3换成F4的话就不起作用了，我上面的换法对不对

xihaihandsp · 发表于 2024-5-7 15:04

xihaihandsp 发表于 2024-5-7 14:58
result(1, 1) = d(4) & 4  'F4单元格地址
brr(1, 1) = 5          'F4单元格值
For i =  ...

如果上面的改法是对的，应该也出结果，E3、F4、G5、D6、C7这5个单元格也满足条件，但是不出结果

		自动登录	找回密码
密码			免费注册

[已解决] 在拉丁方里找满足条件的单元格

评分

评分

评分

浏览过的版块