excel编程

发布网友 发布时间：2022-04-23 13:55

我来回答

共5个回答

热心网友 时间：2023-01-20 18:33

至少对我来说，这个程序并没有那么简单，你要求的报告文字那么多，

起码4个数组才能搞定，我程序写到一半就有点后悔了，但还是坚持写完了。

设计的是 选中要执行的列的单元格，如图

然后从菜单调出宏，找到相应宏名称，执行，就可以了。

代码其中有两块测试内容，可删除可不删除。留着的话，就是报告前面多几句话而已。另外，选区其中有空白单元格、以及0和1之外的内容没关系，程序会排除，只点数0和1。但是，不能选区全是空白单元格。且选区只能在同1列，不能2列或2列以上。由于定义数值类型是Integer，行数超过Integer长度上限不行，好像是3万多吧。

代码如下，自己在宏编辑页面新建一个模块，粘贴进去：

'=======以下是代码全文

Public Sub 统计1及0的连续出现次数()

'定义部分=================

Dim Shang As Integer '定义Shang为鼠标选择的首行

Dim Mhang As Integer '定义Mhang为鼠标选择的末行

Dim Lie As Integer '定义Lie为鼠标选择的列

Shang = Selection.Row '赋值，鼠标选择首行数

Mhang = Selection.Row + Selection.Rows.Count - 1 '赋值，鼠标选择的末行数

Lie = Selection.Column '赋值，列数

Dim Hl As Integer '定义Hl为行流水号

Dim Yis As Integer '定义Yis，用于临时存储1的连续数目

Dim nl As Integer '定义nl为内部临时流水号

Dim s1 As Integer 'ARBYY0数组上限

Dim s0 As Integer 'ARBYY1数组上限

Dim ARBYY1() As Integer '1连续出现次数的顺序序列记录数组

Dim ARBYY0() As Integer '0连续出现次数的顺序序列记录数组

'执行部分======================

Hl = Shang '流水号从所选的首行开始进行

s1 = 0 'ARBYY0数组上限归零

s0 = 0 'ARBYY0数组上限归零

Do While Hl <= Mhang '循环到所选行结束，逐行记录1和0重复出现的情况，记入ARBYY1和ARBYY0数组

If Cells(Hl, Lie) <> "" Then '单元格为空检测，不等于空则执行

If Cells(Hl, Lie) = 1 Then '单元格为1时做记录

nl = Hl

Yis = 0

Do While Cells(nl, Lie) = 1

Yis = Yis + 1

nl = nl + 1

Loop

s1 = s1 + 1

ReDim Preserve ARBYY1(1 To s1)

ARBYY1(s1) = Yis

Hl = Hl + Yis

ElseIf Cells(Hl, Lie) = 0 Then '单元格为0时做记录

nl = Hl

Yis = 0

Do While Cells(nl, Lie) <> "" And Cells(nl, Lie) = 0

Yis = Yis + 1

nl = nl + 1

Loop

s0 = s0 + 1

ReDim Preserve ARBYY0(1 To s0)

ARBYY0(s0) = Yis

Hl = Hl + Yis

Else '单元格为其它值时跳过

Hl = Hl + 1

End If

Else '单元格为空时，跳过单元格

Hl = Hl + 1

End If

Loop

'根据ARBYY0数组统计0的连续出现次数======================

Dim dd0 As Integer '记录序列数组内流水

Dim SUMYY0() As Integer '统计情况数组

Dim Mas0 As Integer '统计情况数组中的最大值

Dim lk0 As Integer '迭代流水

Dim jc0 As Integer '临时记次

Mas0 = Application.WorksheetFunction.Max(ARBYY0) '统计0出现的最大连续次数

For lk0 = 1 To Mas0 '从1次到最大连续次数，依次统计各出现了多少次，出现0次的跳过

jc0 = 0

For dd0 = LBound(ARBYY0) To UBound(ARBYY0)

If ARBYY0(dd0) = lk0 Then

jc0 = jc0 + 1

End If

Next dd0

ReDim Preserve SUMYY0(1 To lk0)

SUMYY0(lk0) = jc0

Next lk0

'--------------------

Dim SSGG0 As String

SSGG0 = "统计0连续出现情况"

Dim lj0 As Integer '连接流水

For lj0 = LBound(SUMYY0) To UBound(SUMYY0)

If SUMYY0(lj0) > 0 Then

SSGG0 = SSGG0 & "，0连续" & lj0 & "次次数" & SUMYY0(lj0)

End If

Next lj0

'根据ARBYY1数组统计1的连续出现次数======================

Dim dd1 As Integer '记录序列数组内流水

Dim SUMYY1() As Integer '统计情况数组

Dim Mas1 As Integer '统计情况数组中的最大值

Dim lk1 As Integer '迭代流水

Dim jc1 As Integer '临时记次

Mas1 = Application.WorksheetFunction.Max(ARBYY1) '统计1出现的最大连续次数

For lk1 = 1 To Mas1 '从1次到最大连续次数，依次统计各出现了多少次，出现0次的跳过

jc1 = 0

For dd1 = LBound(ARBYY1) To UBound(ARBYY1)

If ARBYY1(dd1) = lk1 Then

jc1 = jc1 + 1

End If

Next dd1

ReDim Preserve SUMYY1(1 To lk1)

SUMYY1(lk1) = jc1

Next lk1

'--------------------

Dim SSGG1 As String

SSGG1 = "统计1连续出现情况"

Dim lj1 As Integer '连接流水

For lj1 = LBound(SUMYY1) To UBound(SUMYY1)

If SUMYY1(lj1) > 0 Then

SSGG1 = SSGG1 & "，1连续" & lj1 & "次次数" & SUMYY1(lj1)

End If

Next lj1

'测试部分，可删除======================

Dim ff0 As Integer

Dim StrG0 As String

For ff0 = LBound(ARBYY0) To UBound(ARBYY0)

StrG0 = StrG0 & "，" & ARBYY0(ff0)

Next ff0

Dim ff1 As Integer

Dim StrG1 As String

For ff1 = LBound(ARBYY1) To UBound(ARBYY1)

StrG1 = StrG1 & "，" & ARBYY1(ff1)

Next ff1

'测试输出部分，可删除=====================

MsgBox "首行是" & Shang & "，末行是" & Mhang & "，选择的列是" & Lie & "，1连续序列的数组上限是" & UBound(ARBYY1) & "，0连续序列的数组上限是" & UBound(ARBYY0)

MsgBox "1的连续序列分别是" & StrG1 & "。0的连续序列分别是" & StrG0

MsgBox "0的最大重复次数是" & Mas0 & "。1的最大重复次数是" & Mas1

'=============================

'====输出最终结果，切勿删除=====

MsgBox SSGG0 & "，其余连续出现次数为0。"

MsgBox SSGG1 & "，其余连续出现次数为0。"

End Sub

'=====以上是代码全文

热心网友 时间：2023-01-20 19:51

热心网友 时间：2023-01-20 21:26

热心网友 时间：2023-01-20 23:17

热心网友 时间：2023-01-21 01:25