用Excel VBA来实现的手机上玩的那种组合数字的小游戏。
Public Row As Integer, Col As Integer '偏移
Dim D As Object '颜色
Dim RndRng As Range '随机单元格
Dim SHIFOUYIDONG As Boolean '判断是否移动过
Dim Start As Boolean
Dim sht As Worksheet '
Sub MoveLeft()
If Start <> True Then Exit Sub
SetUndo '设置撤销
Row = 0: Col = -1
YiDongFangXiang1 '移动
HeBing1 '合并
BianDiSe '变换底色
ShiFouGetRndRng '是否产生随机单元格
End Sub
Sub MoveRight()
If Start <> True Then Exit Sub
SetUndo '设置撤销
Row = 0: Col = 1
YiDongFangXiang2
HeBing3
BianDiSe '变换底色
ShiFouGetRndRng '是否产生随机单元格
End Sub
Sub MoveUp()
If Start <> True Then Exit Sub
SetUndo '设置撤销
Row = -1: Col = 0
YiDongFangXiang1
HeBing2
BianDiSe '变换底色
ShiFouGetRndRng '是否产生随机单元格
End Sub
Sub MoveDown()
If Start <> True Then Exit Sub
SetUndo '设置撤销
Row = 1: Col = 0
YiDongFangXiang2
HeBing4
BianDiSe '变换底色
ShiFouGetRndRng '是否产生随机单元格
End Sub
Sub YiDongFangXiang1() '移动的顺序——向左、向上
Dim TempRang As Range
For Each TempRang In Range("B4:E7")
If TempRang.Value > 0 Then YiDong TempRang
Next TempRang
End Sub
Sub YiDongFangXiang2() '移动的顺序——向右、向下
Dim i As Integer '列方向
Dim j As Integer '行方向
For i = 5 To 2 Step -1
For j = 7 To 4 Step -1
If Cells(j, i).Value > 0 Then YiDong Cells(j, i)
Next j
Next i
End Sub
Sub YiDong(Rng As Range) '移动
Do While Rng.Offset(Row, Col) = ""
Rng.Offset(Row, Col).Value = Rng.Value
Rng.Value = ""
Set Rng = Rng.Offset(Row, Col)
SHIFOUYIDONG = True '有移动就生产随机单元格
Loop
End Sub
Sub HeBing1() '相同就合并——向左
Dim TempRng As Range
Dim i As Integer
For i = 4 To 7 Step 1
If Application.WorksheetFunction.Count(Range("B" & i & ":e" & i)) > 1 Then
Set TempRng = Range("B" & i & ":e" & i).SpecialCells(xlCellTypeConstants)
PanDuan1 TempRng
End If
Next i
End Sub
Sub HeBing3() '相同就合并——向右
Dim TempRng As Range
Dim i As Integer
For i = 4 To 7 Step 1
If Application.WorksheetFunction.Count(Range("B" & i & ":e" & i)) > 1 Then
Set TempRng = Range("B" & i & ":e" & i).SpecialCells(xlCellTypeConstants)
PanDuan2 TempRng
End If
Next i
End Sub
Sub HeBing2() '相同就合并——向上
Dim TempRng As Range
Dim i As Integer
For i = 2 To 5 Step 1
If Application.WorksheetFunction.Count(Range(Cells(4, i), Cells(7, i))) > 1 Then
Set TempRng = Range(Cells(4, i), Cells(7, i)).SpecialCells(xlCellTypeConstants)
PanDuan1 TempRng
End If
Next i
End Sub
Sub HeBing4() '相同就合并——向下
Dim TempRng As Range
Dim i As Integer
For i = 2 To 5 Step 1
If Application.WorksheetFunction.Count(Range(Cells(4, i), Cells(7, i))) > 1 Then
Set TempRng = Range(Cells(4, i), Cells(7, i)).SpecialCells(xlCellTypeConstants)
PanDuan2 TempRng
End If
Next i
End Sub
Sub PanDuan1(Rng As Range) '——向左、向上
Select Case Rng.Cells.Count
Case 2: TwoRng Rng.Cells(1), Rng.Cells(2)
Case 3: ThreeRng Rng.Cells(1), Rng.Cells(2), Rng.Cells(3)
Case 4: FourRng Rng.Cells(1), Rng.Cells(2), Rng.Cells(3), Rng.Cells(4)
End Select
End Sub
Sub PanDuan2(Rng As Range) '——向右、向下
Select Case Rng.Cells.Count
Case 2: TwoRng Rng.Cells(2), Rng.Cells(1)
Case 3: ThreeRng Rng.Cells(3), Rng.Cells(2), Rng.Cells(1)
Case 4: FourRng Rng.Cells(4), Rng.Cells(3), Rng.Cells(2), Rng.Cells(1)
End Select
End Sub
'判断相同的相加
Sub TwoRng(Rng1 As Range, Rng2 As Range) '2个单元格的判断
If Rng1.Value = Rng2.Value Then
Rng1.Value = Rng1.Value * 2
Rng2.Value = ""
SHIFOUYIDONG = True '有相加就生产随机单元格
[C2] = [C2] Rng1.Value
End If
End Sub
Sub ThreeRng(Rng1 As Range, Rng2 As Range, Rng3 As Range) '3个单元格的判断
If Rng1.Value = Rng2.Value Then
Rng1.Value = Rng1.Value * 2
Rng2.Value = Rng3.Value
Rng3.Value = ""
SHIFOUYIDONG = True '有相加就生产随机单元格
[C2] = [C2] Rng1.Value
End If
TwoRng Rng2, Rng3
End Sub
Sub FourRng(Rng1 As Range, Rng2 As Range, Rng3 As Range, Rng4 As Range) '4个单元格的判断
If Rng1.Value = Rng2.Value Then
Rng1.Value = Rng1.Value * 2
If Rng3.Value = Rng4.Value Then
Rng2.Value = Rng3.Value * 2
Rng3.Value = "": Rng4.Value = ""
[C2] = [C2] Rng2.Value
Else
Rng2.Value = Rng3.Value
Rng3.Value = Rng4.Value
Rng4.Value = ""
End If
SHIFOUYIDONG = True '有相加就生产随机单元格
[C2] = [C2] Rng1.Value
ElseIf Rng2.Value = Rng3.Value Then
ThreeRng Rng2, Rng3, Rng4
ElseIf Rng3.Value = Rng4.Value Then
TwoRng Rng3, Rng4
End If
End Sub
Sub ShiFouGetRndRng() '是否产生随机单元格
If Application.WorksheetFunction.Count([B4：E7]) <> 16 Then
If SHIFOUYIDONG Then
GetRndRng
SHIFOUYIDONG = False
End If
Else
Dim TempRang As Range, X As Boolean
X = True
For Each TempRang In Range("B4:E7")
If TempRang = TempRang.Offset(0, -1) Or TempRang = TempRang.Offset(0, 1) _
Or TempRang = TempRang.Offset(-1, 0) Or TempRang = TempRang.Offset(1, 0) Then
X = False
Exit For
End If
Next TempRang
If X Then
sht.UsedRange.Delete
MsgBox "你挂了！" & Space(50) & vbNewLine & vbNewLine & "得 分：" & vbTab & [C2] & vbNewLine & vbNewLine & "最 大 值：" & vbTab & [e2], , "2048——By34号！"
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True
JieShu
End If
End If
End Sub
Sub GetRndRng() '生成随机单元格
Dim X As Integer '空白单元格的某一个区域
Dim y As Integer '某一个区域的第y个单元格
Dim BlankRng As Range
On Error Resume Next
Set BlankRng = Range("B4:E7").SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If BlankRng Is Nothing Then
JieShu
Exit Sub
End If
Randomize
X = Int(BlankRng.Areas.Count * Rnd) 1
Set BlankRng = BlankRng.Areas(X)
y = Int(BlankRng.Cells.Count * Rnd) 1
Set RndRng = BlankRng.Cells(y)
If Int(Rnd * 21) = 1 Then
RndRng.Value = 4
RndRng.Interior.ColorIndex = D(4)
Else
RndRng.Value = 2
End If
End Sub
Sub KaiShi()
SHIFOUYIDONG = False: Start = True
[B4:E7].Interior.ColorIndex = -4142: Range("B4:E7") = "": [C2] = 0
DiSe
GetRndRng
Set sht = ThisWorkbook.Worksheets("Undo")
sht.UsedRange.Delete
ActiveSheet.CommandButton2.Enabled = True
ActiveSheet.CommandButton3.Enabled = True
End Sub
Sub JieShu() '结束
If [A1] < [C2] Then [A1] = [C2] '最高分
If [F1] < [e2] Then [F1] = [e2] '最大值
sht.UsedRange.Delete
Application.OnKey "{LEFT}"
Application.OnKey "{RIGHT}"
Application.OnKey "{UP}"
Application.OnKey "{DOWN}"
Set RndRng = Nothing
Set D = Nothing
Start = False
Set sht = Nothing
End Sub
Sub SetUndo() '设置撤销
Dim Rng As Range
With sht
If .[E65533] <> "" Then .[A1:E4].Delete '不能超过65536行
Set Rng = .[E65535].End(xlUp).Offset(1, -4)
If Rng.Address = "$A$2" Then Set Rng = sht.[A1]
Range("B4:E7").Copy Rng '游戏区域
Rng.Offset(0, 4) = RndRng.Address 'RndRng
Rng.Offset(1, 4) = [C2] '当前分数
Rng.Offset(3, 4) = "我是分隔符" '我是分隔符
End With
Set Rng = Nothing
End Sub
Sub ApplyUndo() '应用撤销
Dim Rng As Range
With sht
If .[E65535].End(xlUp).Address = "$E$1" Then Exit Sub
Set Rng = .[E65535].End(xlUp).Offset(-3, -4)
ActiveSheet.Unprotect Password:=7744
Rng.Resize(4, 4).Copy Range("B4:E7")
ActiveSheet.Protect Password:=7744, UserInterfaceOnly:=True
Set RndRng = Range(Rng.Offset(0, 4))
[C2] = Rng.Offset(1, 4)
Rng.Resize(4, 5).Clear
End With
[A1].Select
End Sub
Sub ESCJian()
Set sht = ThisWorkbook.Worksheets("Undo")
JieShu
Application.OnKey "{ESCAPE}"
Application.DisplayAlerts = False
ThisWorkbook.Close True
Application.DisplayAlerts = True
End Sub
Sub BianDiSe() '变换底色
If SHIFOUYIDONG Then
Dim Rng As Range
For Each Rng In [B4:E7]
If Rng > 0 Then
Rng.Interior.ColorIndex = D(Rng.Value)
Else
Rng.Interior.ColorIndex = -4142
End If
Next Rng
End If
End Sub
Sub DiSe() '单元格底色
Dim Rng As Range
Set D = CreateObject("Scripting.Dictionary") '创建字典对象，后期绑定，不需要先引用（工具→引用→浏览→C:WINDOWSsystem32scrrun.dll)
For Each Rng In [H2：H12]
D(Rng.Offset(0, -1).Value) = Rng.Value
Next
End Sub
Sub AnNiu() '设置按钮位置、大小
SetAnNiu "CommandButton1", Range("B9")
SetAnNiu "CommandButton2", Range("C9")
SetAnNiu "CommandButton3", Range("D9")
End Sub
Sub SetAnNiu(StrName As String, TempRang As Range) '设置按钮位置、大小
With ActiveSheet.Shapes(StrName)
.Width = TempRang.Width
.Left = TempRang.Left
.Height = TempRang.Height
.Top = TempRang.Top
End With
End Sub
