奖励100元辛苦费，请你做个软件

lsdongjh

代码供参考，楼主看着办：

1. Type PostInfo
   
2.     TopLeft_RowID As Long '左上角单元格行号
   
3.     TopLeft_ColID As Long '左上角单元格列号
   
4.     BottomRight_RowID As Long '右下角单元格行号
   
5.     BottomRight_ColID As Long '右下角单元格列号
   
6.     Offset_Left_Cols As Long '定位区域左边的列数
   
7.     Offset_Right_Cols As Long '定位区域右边的列数
   
8.     Count_Rows As Long '总行数
   
9.     Count_Cols As Long '总列数
   
10. End Type
    
11. 
    
12. Dim rgStandard As Range '对照区域
    
13. Dim rgSource As Range '比对区域
    
14. Dim rgResult As Range '结果区域
    
15. Dim rgPosition As Range '定位单元格
    
16. Dim rgTemp As Range '临时单元格
    
17. Dim myRgInfo As PostInfo '对照区域的信息
    
18. Dim SourceInfo As PostInfo '比对区域的信息
    
19. Dim objDic As Object '字典对象，存储非空单元格信息
    
20. Dim blIsSelect As Boolean
    
21. 
    
22. Sub myCheck()
    
23.     Dim arr As Variant, strTemp As String
    
24.     Dim lngRow As Long, lngCol As Long
    
25.     Dim lngTemp As Long
    
26.     Dim lngIndex_Row As Long
    
27.     Dim lngIndex_Col As Long
    
28.     Dim myShape As Shape
    
29.     '取消原有背景色
    
30.     'ActiveSheet.Cells.Interior.ColorIndex = 0
    
31.     ' 删除原有圆圈
    
32.    ' DelShapes
    
33.    
    
34.     'Step 1 选择对照区域
    
35.     blIsSelect = False
    
36.     Do Until blIsSelect = True
    
37.         Set rgStandard = GetRange("请选择对照区域", "Step 1 - 对照区域选择")
    
38.         If rgStandard Is Nothing Then Exit Sub
    
39.         blIsSelect = True
    
40.         If rgStandard.Count < 2 Then
    
41.             MsgBox "请正确选择对照区域！"
    
42.             blIsSelect = False
    
43.         End If
    
44.     Loop
    
45.     '对照区域填色
    
46.     'rgStandard.Interior.ColorIndex = 44
    
47.    
    
48.     myRgInfo.TopLeft_RowID = rgStandard.Row
    
49.     myRgInfo.TopLeft_ColID = rgStandard.Column
    
50.     myRgInfo.BottomRight_RowID = rgStandard.Row + rgStandard.Rows.Count - 1
    
51.     myRgInfo.BottomRight_ColID = rgStandard.Column + rgStandard.Columns.Count - 1
    
52.     myRgInfo.Count_Rows = rgStandard.Rows.Count
    
53.     myRgInfo.Count_Cols = rgStandard.Columns.Count
    
54.    
    
55.     'Step 2 选择定位区域
    
56.     Set rgTemp = Range(Cells(myRgInfo.BottomRight_RowID + 1, myRgInfo.TopLeft_ColID), Cells(myRgInfo.BottomRight_RowID + 1, myRgInfo.BottomRight_ColID))
    
57.     blIsSelect = False
    
58.     Do Until blIsSelect = True
    
59.         Set rgPosition = GetRange("请选择定位区域", "Step 2 - 定位区域选择")
    
60.         If rgPosition Is Nothing Then Exit Sub
    
61.         blIsSelect = True
    
62.         If rgPosition.Count > 1 Or (rgPosition.Row <> myRgInfo.BottomRight_RowID + 1) Or rgPosition.Column < myRgInfo.TopLeft_ColID Or rgPosition.Column > myRgInfo.BottomRight_ColID Then
    
63.             MsgBox "定位区域只能在【" & rgTemp.Address(0, 0) & "】中选择，且只能是【1】个单元格"
    
64.             blIsSelect = False
    
65.         Else
    
66.             If Trim(rgPosition.Value) = "" Then
    
67.                 MsgBox "定位区域必须是 非空 单元格！"
    
68.                 blIsSelect = False
    
69.             End If
    
70.         End If
    
71.     Loop
    
72.    
    
73.     '定位区域填色
    
74.     'rgPosition.Interior.ColorIndex = 3
    
75.    
    
76.     myRgInfo.Offset_Left_Cols = rgPosition.Column - myRgInfo.TopLeft_ColID
    
77.     myRgInfo.Offset_Right_Cols = myRgInfo.BottomRight_ColID - rgPosition.Column
    
78.    
    
79.     'Step 3 选择比对区域
    
80.     blIsSelect = False
    
81.     Do Until blIsSelect = True
    
82.         Set rgSource = GetRange("请选择比对区域", "Step 3 - 比对区域选择")
    
83.         If rgSource Is Nothing Then Exit Sub
    
84.         blIsSelect = True
    
85.         If rgSource.Count < 2 Then
    
86.             MsgBox "请正确选择比对区域！"
    
87.             blIsSelect = False
    
88.         End If
    
89.     Loop
    
90.    
    
91.     '比对区域填色
    
92.     'rgSource.Interior.ColorIndex = 6
    
93.    
    
94.     SourceInfo.TopLeft_RowID = rgSource.Row
    
95.     SourceInfo.TopLeft_ColID = rgSource.Column
    
96.     SourceInfo.BottomRight_RowID = rgSource.Row + rgSource.Rows.Count - 1
    
97.     SourceInfo.BottomRight_ColID = rgSource.Column + rgSource.Columns.Count - 1
    
98.     SourceInfo.Count_Rows = rgSource.Rows.Count
    
99.     SourceInfo.Count_Cols = rgSource.Columns.Count
    
100.    
     
101.     '结果显示区域
     
102.     Set rgResult = Range(Cells(SourceInfo.BottomRight_RowID + 1, SourceInfo.TopLeft_ColID), Cells(SourceInfo.BottomRight_RowID + 1, SourceInfo.BottomRight_ColID))
     
103.    
     
104.     '结果区域填色
     
105.     'rgResult.Interior.ColorIndex = 3
     
106.    
     
107.     '将对照区域的非空单元格存入字典
     
108.     Set objDic = CreateObject("Scripting.Dictionary")
     
109.     arr = rgStandard
     
110.     For lngRow = LBound(arr) To UBound(arr)
     
111.         For lngCol = LBound(arr, 2) To UBound(arr, 2)
     
112.             strTemp = arr(lngRow, lngCol)
     
113.             If Trim(strTemp) <> "" Then
     
114.                 strTemp = lngRow & "," & lngCol
     
115.                 objDic(strTemp) = ""
     
116.             End If
     
117.         Next
     
118.     Next
     
119.    
     
120.     '开始比对
     
121.     If myRgInfo.Count_Rows < SourceInfo.Count_Rows Then
     
122.         lngIndex_Row = 0
     
123.     Else
     
124.         lngIndex_Row = myRgInfo.Count_Rows - SourceInfo.Count_Rows
     
125.     End If
     
126.    
     
127.     For Each rgTemp In rgResult
     
128.         lngTemp = rgTemp.Column - SourceInfo.TopLeft_ColID
     
129.         If lngTemp > myRgInfo.Offset_Left_Cols Then lngTemp = myRgInfo.Offset_Left_Cols
     
130.         SourceInfo.Offset_Left_Cols = lngTemp
     
131.         
     
132.         lngTemp = SourceInfo.BottomRight_ColID - rgTemp.Column
     
133.         If lngTemp > myRgInfo.Offset_Right_Cols Then lngTemp = myRgInfo.Offset_Right_Cols
     
134.         SourceInfo.Offset_Right_Cols = lngTemp
     
135.       
     
136.         lngIndex_Col = myRgInfo.Offset_Left_Cols - SourceInfo.Offset_Left_Cols
     
137.         
     
138.         arr = rgTemp.Offset(SourceInfo.Count_Rows * -1, SourceInfo.Offset_Left_Cols * -1).Resize(myRgInfo.Count_Rows - lngIndex_Row, myRgInfo.Count_Cols - lngIndex_Col)
     
139.         lngTemp = 0
     
140.         For lngRow = LBound(arr) To UBound(arr)
     
141.             For lngCol = LBound(arr, 2) To UBound(arr, 2)
     
142.                 strTemp = arr(lngRow, lngCol)
     
143.                 If Trim(strTemp) <> "" Then
     
144.                     strTemp = lngRow + lngIndex_Row & "," & lngCol + lngIndex_Col
     
145.                     If objDic.Exists(strTemp) Then lngTemp = lngTemp + 1
     
146.                 End If
     
147.             Next
     
148.         Next
     
149.         If lngTemp >= 2 Then
     
150.             rgTemp.Value = lngTemp
     
151.             Set myShape = ActiveSheet.Shapes.AddShape(msoShapeOval, rgTemp.Left, rgTemp.Top, rgTemp.Width, rgTemp.Height)
     
152.             myShape.Fill.Visible = msoFalse
     
153.             myShape.Line.Weight = 2
     
154.             myShape.Line.ForeColor.ObjectThemeColor = msoThemeColorAccent4
     
155.             Set myShape = Nothing
     
156.         End If
     
157.     Next
     
158.    
     
159.     MsgBox "比对OK"
     
160. End Sub
     
161. 
     
162. 
     
163. Function GetRange(strPrompt As String, Optional strTitle As String = "区域选择") As Range
     
164.     On Error Resume Next
     
165.     Set GetRange = Application.InputBox(Prompt:=strPrompt, Title:=strTitle, Type:=8)
     
166.     On Error GoTo 0
     
167. End Function
     
168. 
     
169. Function DelShapes()
     
170.     Dim sh As Shape
     
171.     For Each sh In ActiveSheet.Shapes
     
172.         If sh.Type = 1 Then sh.Delete
     
173.     Next
     
174. End Function
     

复制代码

zopey

矩形区域 是挺很简单，能直接赋值给二维数组；
提高难度，设想为一个不规则连续的 蛇形区域。

lizhipei78

大神就是厉害啊，真的是什么都能解决，我有一个比这个简单的题目，如果我也给100元，是否也有人做的出来呢

zhang6029

附件有密码，是什么