用VBA判断平行四边形填充绿色底单元格

laoau138 · 发表于 2016-10-1 08:20

本帖最后由 laoau138 于 2016-10-1 08:21 编辑

用VBA判断平行四边形填充绿色底单元格

grf1973 · 发表于 2016-10-1 21:33

很有意思的题目，大家开动脑筋想啊。

today0427 · 发表于 2016-10-1 21:37

本帖最后由 today0427 于 2016-10-1 21:58 编辑

大神你来做，我来学习！

看了一下，这个题目好像还挺复杂的

grf1973 · 发表于 2016-10-2 10:27

Sub tt()
arr = Range("c11:c" & [c65536].End(3).Row)
n = UBound(arr)
Set dic = CreateObject("scripting.dictionary") '储存任意2点的向量所对应的2行
For i = 1 To n - 1 'n - 1
k1 = arr(i, 1)
For j = i + 1 To i + 8 '最大不超过10行
If j <= n Then
k2 = arr(j, 1)
xkey = k2 - k1 & "," & j - i '以向量为key(相同向量表示方向相同，长度相同，2条相同向量可以组成一个平行四边形
dic(xkey) = dic(xkey) & "/" & i & "、" & j '以2行行数为item
End If
Next
Next
Set d = CreateObject("scripting.dictionary")
For Each xkey In dic.keys '对于相同向量
y = Mid(dic(xkey), 2) '取行
If InStr(y, "/") > 0 Then '如果超过4个点，可组成平行四边形
yrr = Split(y, "/")
For k1 = 0 To UBound(yrr) - 1 '第1、2点
ij1 = yrr(k1)
i1 = Val(ij1)
j1 = Val(Mid(ij1, InStr(ij1, "、") + 1))
For k2 = k1 + 1 To UBound(yrr) '第3、4点
ij2 = yrr(k2)
i2 = Val(ij2)
j2 = Val(Mid(ij2, InStr(ij2, "、") + 1))
If i1 <> i2 And i1 <> j2 And j1 <> i2 And j1 <> j2 Then '没有重合点
If j2 - i1 <= 10 Then '行数限制
If j1 > i2 Then '各点从小到大，进字典去重
d(i1 & "、" & i2 & "、" & j1 & "、" & j2) = ""
Else
d(i1 & "、" & j1 & "、" & i2 & "、" & j2) = ""
End If
End If
End If
Next
Next
End If
Next
[y:y] = "" '显示结果
If d.Count > 0 Then [y1].Resize(d.Count) = Application.Transpose(d.keys)
End Sub

复制代码

grf1973 · 发表于 2016-10-2 10:28

结果显示在Y列，每行表示符合条件的4个点。里面的行数是相对于第11行的相对行数。

laoau138 · 发表于 2016-10-2 11:59

grf1973 发表于 2016-10-2 10:28
结果显示在Y列，每行表示符合条件的4个点。里面的行数是相对于第11行的相对行数。

你在搞什么，把组成平行四边形的行号放到Y列

需要对，组成平行四边形的数字单元格填充颜色

today0427 · 发表于 2016-10-2 17:22

本帖最后由 today0427 于 2016-10-2 20:14 编辑

这题把我快弄头昏死，做完了，都变绿了，我也没办法，结果的行号和列号显示在V列和W列，每四个为一组，反正我测试了，每四个确实能组成平行四边形，楼主也没说清楚要求，我是把所有的平行四边形的可能性全部列出来了，有重复利用的单元格。

Dim arr(), n&, brr(1 To 10000, 1 To 2), k&, h&
Sub pxsbx() '平行四边形
Dim rng As Range, rg As Range, i&
e = Sheets("sheet2").[a65536].End(3).Row
Set rng = Range("e11:t" & e)
ReDim arr(1 To e, 1 To 2)
For Each rg In rng
If rg <> "" Then
i = i + 1: arr(i, 1) = rg.Row: arr(i, 2) = rg.Column
End If
Next
For n = 1 To UBound(arr) - 3
Call r2(n)
Next
' MsgBox k
With Sheets("sheet2")
For i = 1 To k
.Cells(brr(i, 1), brr(i, 2)).Interior.ColorIndex = 4
Next
.[v13].Resize(k, 2).Clear
.[v13].Resize(k, 2) = brr
End With
Erase brr: Erase arr: n = 0: h = 0: k = 0
End Sub
Function r2(n)
Dim hc%, lc%, i&
For i = n + 1 To n + 7
If i < UBound(arr) - 2 Then
hc = arr(i, 1) - arr(n, 1): lc = arr(i, 2) - arr(n, 2)
Call r34(hc, lc, i)
End If
Next
End Function
Function r34(hc, lc, m)
Dim i&, j&
For i = m + 1 To n + 8
For j = i + 1 To i + hc
If arr(j, 1) - arr(n, 1) < =10 And arr(j, 1) - arr(i, 1) = hc And arr(j, 2) - arr(i, 2) = lc Then
k = k + 1
brr(k, 1) = arr(n, 1): brr(k, 2) = arr(n, 2)
brr(k + 1, 1) = arr(m, 1): brr(k + 1, 2) = arr(m, 2)
brr(k + 2, 1) = arr(i, 1): brr(k + 2, 2) = arr(i, 2)
brr(k + 3, 1) = arr(j, 1): brr(k + 3, 2) = arr(j, 2)
k = k + 3: Exit For
End If
Next
Next
End Function

复制代码

laoau138 · 发表于 2016-10-2 18:10

grf1973 发表于 2016-10-2 10:27

高手再看这个

用VBA推算组成平行四边形最后一个数字

http://www.excelpx.com/thread-424828-1-1.html

laoau138 · 发表于 2016-10-2 18:10

today0427 发表于 2016-10-2 17:22
这题把我快弄头昏死，做完了，都变绿了，我也没办法，结果的行号和列号显示在V列和W列，每四个为一组，反正 ...

高手再看这个

用VBA推算组成平行四边形最后一个数字

http://www.excelpx.com/thread-424828-1-1.html

today0427 · 发表于 2016-10-2 18:26

grf1973 发表于 2016-10-2 10:28
结果显示在Y列，每行表示符合条件的4个点。里面的行数是相对于第11行的相对行数。

大神，有空帮我看看为什么我的结果比你少了好多组，查看了你的结果确实对着，但是我的代码哪里有漏洞了？辛苦大神了！

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

[VBA] 用VBA判断平行四边形填充绿色底单元格

本帖子中包含更多资源

本帖子中包含更多资源

评分

评分

本帖子中包含更多资源

评分