Loading [MathJax]/jax/output/CommonHTML/config.js
前往小程序,Get更优阅读体验!
立即前往
首页
学习
活动
专区
圈层
工具
发布
首页
学习
活动
专区
圈层
工具
MCP广场
社区首页 >专栏 >小游戏2048

小游戏2048

作者头像
xyj
发布于 2020-07-28 02:31:59
发布于 2020-07-28 02:31:59
80600
代码可运行
举报
文章被收录于专栏:VBA 学习VBA 学习
运行总次数:0
代码可运行

用Excel VBA来实现的手机上玩的那种组合数字的小游戏。

代码语言:javascript
代码运行次数:0
运行
AI代码解释
复制
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([B4E7]) <> 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:\WINDOWS\system32\scrrun.dll)
    For Each Rng In [H2H12]
        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
本文参与 腾讯云自媒体同步曝光计划,分享自微信公众号。
原始发表:2020-05-05,如有侵权请联系 cloudcommunity@tencent.com 删除

本文分享自 VBA 学习 微信公众号,前往查看

如有侵权,请联系 cloudcommunity@tencent.com 删除。

本文参与 腾讯云自媒体同步曝光计划  ,欢迎热爱写作的你一起参与!

评论
登录后参与评论
暂无评论
推荐阅读
编辑精选文章
换一批
Excel VBA编程
在Excel中,数据只有文本,数值,日期值,逻辑值和错误值五种类型。但是在VBA中,数据类型跟Excel不完全相同。根据数据的特点,VBA将数据分为布尔型(boolean),字节型(byte),整数型(integer),单精度浮点型(single),双精度浮点型(double),货币型(currency),小数型(decimal),字符串型(string),日期型(date),对象型等等
全栈程序员站长
2022/08/11
46.7K0
Excel VBA编程
EXCEL VBA语句集300
        定制模块行为 (1) Option Explicit ‘强制对模块内所有变量进行声明 Option Private Module ‘标记模块为私有,仅对同一工程中其它模块有用,在宏对话框中不显示  Option Compare Text ‘字符串不区分大小写  Option Base 1 ‘指定数组的第一个下标为1 (2) On Error Resume Next ‘忽略错误继续执行VBA代码,避免出现错误消息 (3) On Error GoTo ErrorHandler ‘当错误发生时跳转到过程中的某个位置 (4) On Error GoTo 0 ‘恢复正常的错误提示 (5) Application.DisplayAlerts=False ‘在程序执行过程中使出现的警告框不显示 (6) Application.ScreenUpdating=False ‘关闭屏幕刷新 Application.ScreenUpdating=True ‘打开屏幕刷新 (7) Application.Enable.CancelKey=xlDisabled ‘禁用Ctrl+Break中止宏运行的功能  工作簿 (8) Workbooks.Add() ‘创建一个新的工作簿 (9) Workbooks(“book1.xls”).Activate ‘激活名为book1的工作簿 (10) ThisWorkbook.Save ‘保存工作簿 (11) ThisWorkbook.close ‘关闭当前工作簿 (12) ActiveWorkbook.Sheets.Count ‘获取活动工作薄中工作表数 (13) ActiveWorkbook.name ‘返回活动工作薄的名称 (14) ThisWorkbook.Name ‘返回当前工作簿名称 ThisWorkbook.FullName ‘返回当前工作簿路径和名称 (15) ActiveWindow.EnableResize=False ‘禁止调整活动工作簿的大小 (16) Application.Window.Arrange xlArrangeStyleTiled ‘将工作簿以平铺方式排列 (17) ActiveWorkbook.WindowState=xlMaximized ‘将当前工作簿最大化  工作表 (18) ActiveSheet.UsedRange.Rows.Count ‘当前工作表中已使用的行数 (19) Rows.Count ‘获取工作表的行数(注:考虑向前兼容性) (20) Sheets(Sheet1).Name= “Sum” ‘将Sheet1命名为Sum (21) ThisWorkbook.Sheets.Add Before:=Worksheets(1) ‘添加一个新工作表在第一工作表前 (22) ActiveSheet.Move After:=ActiveWorkbook. _ Sheets(ActiveWorkbook.Sheets.Count) ‘将当前工作表移至工作表的最后 (23) Worksheets(Array(“sheet1”,”sheet2”)).Select ‘同时选择工作表1和工作表2 (24) Sheets(“sheet1”).Delete或 Sheets(1).Delete ‘删除工作表1 (25) ActiveWorkbook.Sheets(i).Name ‘获取工作表i的名称 (26) ActiveWindow.DisplayGridlines=Not ActiveWindow.DisplayGridlines ‘切换工作表中的网格线显示,这种方法也可以用在其它方面进行相互切换,即相当于开关按钮 (27) ActiveWindow.DisplayHeadings=Not ActiveWindow.DisplayHeadings ‘切换工作表中的行列边框显示 (28) ActiveSheet.UsedRange.FormatConditions.Delete ‘删除当前工作表中所有的条件格式 (29) Cells.Hyperlinks.Delete ‘取消当前工作表所有超链接 (30) ActiveSheet.PageSetup.Orientation=xlLandscape 或ActiveSheet.PageSetup.Orientation=2 ‘将页面设置更改为横向 (31) ActiveSheet.PageSetup.RightFooter=ActiveWorkbook.FullName ‘在页面设置的表尾中输入文件路径 ActiveSheet.PageSetup.Le
Tony老师
2020/03/05
2.3K0
小游戏:围住神经猫
用Excel VBA实现的围住神经猫游戏: 模块代码: Public MGraph(80, 80) As Long Public Patharc(80) As Long '存储最短路径下标 P
xyj
2020/07/28
4500
小游戏:围住神经猫
删除多行多列中的空单元格并重新整理数据
这是在www.vbaexpress.com中看到的一个示例,个人觉得代码很有代表性,特辑录于此,与大家共享。
fanjy
2024/05/13
3960
删除多行多列中的空单元格并重新整理数据
ExcelVBA批量合并或取消单元格
【问题】烦人的合并单元格,我们在进行vlookup、sum等计算中最怕就是遇到神人交过来的表格,
哆哆Excel
2022/10/25
2.2K0
ExcelVBA批量合并或取消单元格
VBA对象变量
大家好,前面介绍了vba中两个主要的对象,单元格range对象和工作表worksheet对象,以及它们的属性和方法。
无言之月
2019/10/13
2K0
ExcelVBA请按班别拆分为工作簿(筛选复制法)
请按班别拆分为工作簿 Sub 筛选拆分() Dim d As Object, sht As Worksheet, arr,brr, r, kr, i&, j&, k&, x& Dim Rng As Range, Rg As Range, tRow&,tCol&, aCol&, pd&, Cll As Range Dim wb As Object, mysht As Worksheet Set d =CreateObject("scripting.dictionary") '
哆哆Excel
2022/10/31
4650
VBA实战技巧20:选取不同工作表中不同单元格区域时禁止用户执行复制剪切粘贴操作
在《VBA实战技巧19:根据用户在工作表中的选择来隐藏/显示功能区中的剪贴板组》中,我们讲解了根据用户在工作表中的选择来决定隐藏或者显示功能区选项卡中的特定组的技术。在这里就要派上用场了。
fanjy
2021/03/12
2.4K0
Excel将单元格内的url批量转化为图片格式的三种方法
开发工具——Visual Basic(或者ALT+F11快捷键)进入VB界面,然后双击sheet1按钮打开VB编程窗口
TOMOCAT
2020/06/09
19.4K4
Excel将单元格内的url批量转化为图片格式的三种方法
循环语句For each...next语句
大家好,前面已经介绍过循环结构的for..next和do...loop系列语句。还有一种用于处理对象集合的循环语句,即for each...next语句,在本节介绍。(下面程序控制结构图帮助回顾)
无言之月
2019/10/13
2.2K0
VBA基础:复制格式、选取单元格及复制工作表的示例代码
fanjy
2024/05/25
5370
VBA基础:复制格式、选取单元格及复制工作表的示例代码
Excel实战技巧61: 处理剪切、复制和粘贴操作,使它们不会破坏已设置的单元格格式
这是《Professional Excel Development》中介绍的一个技巧,特整理分享于此。
fanjy
2019/11/13
2.1K0
ExceVBA删除指定字符所在的行_优化版
哆哆Excel
2023/09/09
5380
ExceVBA删除指定字符所在的行_优化版
使用VBA进行线性插值
其实原理很简单,代码也不难。之所以分享这个示例,主要是其使用了SpecialCells方法来获取相应的单元格组织单元格区域,有兴趣的朋友可以好好体会。
fanjy
2024/07/05
3000
使用VBA进行线性插值
VBA实用小程序:核查并标记公式是否被正确复制
下面的代码将复制活动工作表,然后标记公式,使用阴影显示已复制哪些以及从何处复制。它从左到右、从上到下进行核查。
fanjy
2023/02/14
5140
VBA实用小程序:核查并标记公式是否被正确复制
ExcelVBA筛选法按分类条件拆分一个工作表为多个工作簿
对上次的文章进行优化 ==========代码如下===== Sub 筛选拆分() Dim d As Object, sht As Worksheet, arr, brr, r, kr, i&, j&, k&, x& Dim Rng As Range, Rg As Range, tRow&, tCol& Dim wb As Object, mysht As Worksheet Set d = CreateObject("scripting.dictionary") 'se
哆哆Excel
2022/10/31
3.7K1
问与答114:应用Split函数拆分成数组时出错?
Q:我有一列数据,其中有很多数据以“%”分隔,也有一些数据没有“%”,如下图1所示。
fanjy
2021/04/21
9890
问与答114:应用Split函数拆分成数组时出错?
VBA将一行数据分为多行
有个表格,有许多单元格的数据,制作者为了方便,很多数据是写在一行的,类似下面这种:
xyj
2020/07/28
4.8K2
VBA将一行数据分为多行
VBA汇总一个文件多工作表到一个表
VBA汇总一个文件多工作表到一个表 . 今天在工作中,同事传来一个excel文件中有很多个工作表,要我汇总,每个表的标题是一样的,虽然一个一个复制、粘贴是可以做到的,但时间很长,所以把以前学习一个代码,拿来用一下,代码找了很久才找到,想想还是把他放在这里好一点,以后查找方便 . 把多个工作表的内容汇总到一个“汇总”表中 Sub sheets_to_one() Dim mysht As Worksheet, rng As Range, sht As Worksheet Dim
哆哆Excel
2022/10/31
5850
Excel技巧:使用上方单元格的值填充空单元格
有时候,工作表列中有许多空单元格,而不是在每行都重复相同的内容,这样可以使报表更容易阅读,然而也会导致一些问题,例如不方便排序或筛选数据。
fanjy
2022/04/13
3.6K0
Excel技巧:使用上方单元格的值填充空单元格
推荐阅读
相关推荐
Excel VBA编程
更多 >
领券
问题归档专栏文章快讯文章归档关键词归档开发者手册归档开发者手册 Section 归档
本文部分代码块支持一键运行,欢迎体验
本文部分代码块支持一键运行,欢迎体验