|
|
昨天排列三开奖517，代码有误，导致第三位7下面没有全部标红，请帮忙修改下：
Xrows = OpenWs.Range("E65536").End(xlUp).Row
'填充百位号
XArr = OpenWs.Range("F9:H" & Xrows).Value
Range("A" & Brow & ":C" & Xrows - 6).Value = XArr
'如果打开主界面则关闭
If ThisWorkbook.Sheets.Count = 1 Then NewWb.Close
'获得最后A列的有效行数
LastUsedRow = Range("A65536").End(xlUp).Row
'奖号区域
DataArr = Range("A3:C" & LastUsedRow).Value
'组合区域
ReDim ComFillArr(1 To LastUsedRow - Brow + 2, 1 To 198)
ReDim FillArr1(1 To LastUsedRow - Brow + 2, 1 To 198)
ReDim FillArr2(1 To LastUsedRow - Brow + 2, 1 To 198)
ReDim FillArr3(1 To LastUsedRow - Brow + 2, 1 To 198)
ReDim FillArr4(1 To LastUsedRow - Brow + 2, 1 To 198)
ReDim FillArr5(1 To LastUsedRow - Brow + 2, 1 To 198)
ReDim Arr1(1 To 15, 1 To 198)
ReDim Arr2(1 To 15, 1 To 198)
ReDim arr3(1 To 15, 1 To 198)
ReDim arr4(1 To 15, 1 To 198)
ReDim arr5(1 To 15, 1 To 198)
Set ComRange = Range("G" & Brow & ":GV" & 23)
ReDim ComArr(1 To 21, 1 To 198)
ReDim NumArr(1 To 20, 1 To 3)
'开始计算
For i = 1 To LastUsedRow - Brow + 1
'填充百
TagNum = DataArr(i, 1)
ComFillArr(i, 1) = TagNum
ComFillArr(i, TagNum + 1 + 1) = TagNum
'填充十个
If i > 1 Then
TagNum = DataArr(i, 2)
TagNum = Int(Right(TagNum, 1))
ComFillArr(i, 12) = TagNum
ComFillArr(i, TagNum + 1 + 12) = TagNum
TagNum = DataArr(i, 3)
TagNum = Int(Right(TagNum, 1))
ComFillArr(i, 23) = TagNum
ComFillArr(i, TagNum + 1 + 23) = TagNum
End If
'计算总遗漏
For j = 1 To 198
If (j - 1) Mod 11 <> 0 Then
If j > 1 And j <= 11 Then bgin = 1
If j > 12 And j <= 22 Then bgin = 2
If j > 23 And j <= 33 Then bgin = 2
If j > 34 And j <= 44 Then bgin = 2
If j > 45 And j <= 55 Then bgin = 3
If j > 56 And j <= 66 Then bgin = 3
If j > 67 And j <= 77 Then bgin = 1
If j > 78 And j <= 88 Then bgin = 2
If j > 89 And j <= 99 Then bgin = 2
If j > 100 And j <= 110 Then bgin = 2
If j > 111 And j <= 121 Then bgin = 3
If j > 122 And j <= 132 Then bgin = 3
n1 = 0
For i = bgin To LastUsedRow - Brow + 2
If ComFillArr(i, j) <> "" Then
n1 = 0
Else
n1 = n1 + 1
ComFillArr(i, j) = n1 & " "
End If
Next
End If
Next
'遗漏1
For j = 1 To 18
For i = 2 To LastUsedRow - Brow + 1
n = 0
For k = i - 1 To 1 Step -1
If ComFillArr(i, 1 + (j - 1) * 11) <> ComFillArr(k, 1 + (j - 1) * 11) Then
n = n + 1
Else
Exit For
End If
Next
n = Int(Right(n, 1))
FillArr1(i, 1 + (j - 1) * 11) = n
FillArr1(i, 2 + n + (j - 1) * 11) = n
Next
Next
For j = 1 To 198
If (j - 1) Mod 11 <> 0 Then
n1 = 0
For i = 1 To LastUsedRow - Brow + 2
If FillArr1(i, j) <> "" Then
n1 = 0
Else
n1 = n1 + 1
FillArr1(i, j) = n1 & " "
End If
Next
End If
Next
For i = 1 To 15
For j = 1 To 198
Arr1(i, j) = FillArr1(UBound(FillArr1) - 15 + i, j)
Next
Next
'遗漏2
For j = 1 To 18
For i = 1 To LastUsedRow - Brow + 1
n = 0
For k = i - 1 To 1 Step -1
If FillArr1(i, 1 + (j - 1) * 11) <> FillArr1(k, 1 + (j - 1) * 11) Then
n = n + 1
Else
Exit For
End If
Next
n = Int(Right(n, 1))
FillArr2(i, 1 + (j - 1) * 11) = n
FillArr2(i, 2 + n + (j - 1) * 11) = n
Next
Next
For j = 1 To 198
If (j - 1) Mod 11 <> 0 Then
n1 = 0
For i = 1 To LastUsedRow - Brow + 2
If FillArr2(i, j) <> "" Then
n1 = 0
Else
n1 = n1 + 1
FillArr2(i, j) = n1 & " "
End If
Next
End If
Next
For i = 1 To 15
For j = 1 To 198
Arr2(i, j) = FillArr2(UBound(FillArr2) - 15 + i, j)
Next
Next
'号码区域重新赋值
For i = 1 To 20
For j = 1 To 3
NumArr(i, j) = DataArr(UBound(DataArr) - 20 + i, j)
Next
Next
For i = 1 To 21
For j = 1 To 198
ComArr(i, j) = ComFillArr(UBound(ComFillArr) - 21 + i, j)
Next
Next
Range("A3:C" & LastUsedRow).ClearContents
Range("A3:C22").Value = NumArr
'组合区域
ComRange = ComArr
'遗漏1
Range("G25:GV39").Value = Arr1
'遗漏2
Range("G41:GV55").Value = Arr2
'遗漏3
Range("G41:GV55").Offset(16 * (3 - 2), 0).Value = arr3
DrawingLine '连线
'字体恢复
Range("TagRed").Font.Color = RGB(256, 256, 256)
Range("TagRed").Font.Bold = False
For i = 39 To 263 Step 16
Range(Cells(i, 8), Cells(i, 205)).Font.Color = RGB(256, 256, 256)
Range(Cells(i, 8), Cells(i, 205)).Font.Bold = False
Next
For j = 1 To 6
IntFir1 = Int(ComArr(20, 1 + (j - 1) * 33))
For k = 0 To 9
TagNum = Int(Right(IntFir1 + k, 1))
ComRange.Cells(21, 13 + TagNum + (j - 1) * 33).Font.ColorIndex = 5
ComRange.Cells(21, 13 + TagNum + (j - 1) * 33).Font.Bold = True
TagNum = Int(Right(Abs(IntFir1 - k), 1))
ComRange.Cells(21, 24 + TagNum + (j - 1) * 33).Font.ColorIndex = 5
ComRange.Cells(21, 24 + TagNum + (j - 1) * 33).Font.Bold = True
Next
Next
'遗漏循环标红
drawingRed ComArr, 1
drawingRed Arr1, 2
drawingRed Arr2, 3
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton1_Click()
HTObai
End Sub
Sub CountFun(xIndex As Integer)
'计算遗漏
For i = xIndex + 1 To LastUsedRow - Brow + 1
n = 0
For k = i - 1 To xIndex Step -1
If ComFillArr(i, 11 * (xIndex - 1) + 1) <> ComFillArr(k, 11 * (xIndex - 1) + 1) Then
n = n + 1
Else
Exit For
End If
Next
n = Int(Right(n, 1))
ComFillArr(i, 11 * xIndex + 1) = n
ComFillArr(i, 11 * xIndex + n + 2) = n
Next
End Sub
Sub drawingRed(arr, i) '遗漏标红
'标红遗漏1
For j = 1 To 18
For k = 0 To 9
If Cells(23 + 16 * (i - 1), 8 + k + (j - 1) * 11).Font.ColorIndex = 5 Then
strTem = arr(UBound(arr) - 1, 2 + k + (j - 1) * 11)
If Right(strTem, 1) <> " " Then
TagNum = 0
Else
TagNum = Val(strTem)
End If
TagNum = Int(Right(TagNum, 1))
Cells(39 + 16 * (i - 1), 8 + TagNum + (j - 1) * 11).Font.ColorIndex = 5
Cells(39 + 16 * (i - 1), 8 + TagNum + (j - 1) * 11).Font.Bold = True
End If
Next
Next
End Sub
Sub DrawingLine()
'添加连线
For Each pSha In ActiveSheet.Shapes
If pSha.Type = 9 Then pSha.Delete
Next
ReDim AddLineArr(1 To 20)
xAddNum = 0
For Each Rng In Range("MainData1")
With Rng
If Right(.Value, 1) <> " " Then
xAddNum = xAddNum + 1
AddLineArr(xAddNum) = .Value & "-" & (.Left + .Width / 2) & "-" & (.Top + .Height / 2)
End If
End With
If xAddNum = 20 Then
For i = 1 To 19
SplitStr1 = Split(AddLineArr(i), "-")
SplitStr2 = Split(AddLineArr(i + 1), "-")
Value1 = SplitStr1(0)
Left1 = SplitStr1(1)
Top1 = SplitStr1(2)
Value2 = SplitStr2(0)
Left2 = SplitStr2(1)
Top2 = SplitStr2(2)
If Value1 <> Value2 Then
With ActiveSheet.Shapes.AddLine(Left1, Top1, Left2, Top2).Line
.ForeColor.RGB = RGB(200, 200, 200)
.Weight = 0.01
End With
End If
Next
ReDim AddLineArr(1 To 20)
xAddNum = 0
End If
Next
'循环遗漏连线
For m = 1 To 15
ReDim AddLineArr(1 To 14)
xAddNum = 0
For Each Rng In Union(Range("MainData2"), Range("gm25:gv38")).Offset(16 * (m - 1), 0)
With Rng
If Right(.Value, 1) <> " " Then
xAddNum = xAddNum + 1
AddLineArr(xAddNum) = .Value & "-" & (.Left + .Width / 2) & "-" & (.Top + .Height / 2)
End If
End With
If xAddNum = 14 Then
For i = 1 To 13
SplitStr1 = Split(AddLineArr(i), "-")
SplitStr2 = Split(AddLineArr(i + 1), "-")
Value1 = SplitStr1(0)
Left1 = SplitStr1(1)
Top1 = SplitStr1(2)
Value2 = SplitStr2(0)
Left2 = SplitStr2(1)
Top2 = SplitStr2(2)
If Value1 <> Value2 Then
With ActiveSheet.Shapes.AddLine(Left1, Top1, Left2, Top2).Line
.ForeColor.RGB = RGB(200, 200, 200)
.Weight = 0.01
End With
End If
Next
ReDim AddLineArr(1 To 14)
xAddNum = 0
End If
Next
Next
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-7-24 11:58
楼主