求大神改一个vba代码

wanwfy · 发表于 2018-10-2 16:26

我手里有一个数据处理的表格工具，但是这个表格只能处理65536行的数据现在高版本的excel好像已经最多支持处理100多万行的数据的，不知道有大神能不能帮我看一下能不能突破只能65536行数据的限制，我自己进代码里面把65536全部改成1000000，结果提示错误了。麻烦有经验的大神帮我看看，先谢谢啦！

数据处理.rar (66.45 KB, 下载次数: 3)

duquancai · 发表于 2018-10-2 16:29

代码贴出来》》》》》》》》》》》》》》》》》》》》》》》》》手机没法看》》》》》》

wanwfy · 发表于 2018-10-2 16:44

本帖最后由 wanwfy 于 2018-10-2 16:45 编辑

Sub XXX_模糊分组()
Dim t As Single ' 统计代码运行时间
t = Timer
Application.ScreenUpdating = False '关闭屏幕刷新提高运行速度
Dim max, b, c, d, h, i, j, k As Integer
Dim keywords As String
Dim arr1(), arr2()
Range("A3:A65536").Font.ColorIndex = 0 '以A3为起点，从左至右，从上至下，区域内的单元格字体颜色为黑色
Range("B3:IV65536").ClearContents '清空，从以B3为起点，从左至右，从上至下，区域内的单元格内容
max = [A65536].End(3).Row '获取A列从第3行开始统计总共有数据的行数，也就是关键词的总个数
b = [iv2].End(xlToLeft).Column '获取第二行，词根行的总个数
c = 0 '获取分组的关键词总个数,初始化为0
arr1 = Range("A3:A" & max) '取待分关键词
arr2 = Range("2:2") '取词根
Range("A1") = "工具使用说明，加Q:34569268 SEM联盟-赵阳"
For i = 3 To b '词根开始
h = 0
k = 3
For jj = 1 To UBound(arr1) '取关键词开始
If Cells(jj + 2, 1).Font.ColorIndex <> 15 Then '未分组的词，无颜色，即进行分组
arr = Split(arr2(1, i), "&")
x = Int(UBound(arr) + 1)
If x > 4 Then
MsgBox "对不起，为减少计算占用内存程序暂时只支持最多4个词根的完全存在的组合，请检查词根是否有大于3个“&”", 48, "问题提示"
End If
If x = 1 Then
If arr1(jj, 1) Like "*" & arr2(1, i) & "*" Then
Cells(k, i) = arr1(jj, 1)
Range("A" & jj + 2).Font.ColorIndex = 15
k = k + 1
c = c + 1
End If
ElseIf x > 1 Then
Select Case x
Case 2
If arr1(jj, 1) Like "*" & arr(0) & "*" Or arr1(jj, 1) Like "*" & arr(1) & "*" Then
Cells(k, i) = arr1(jj, 1)
Range("A" & jj + 2).Font.ColorIndex = 15
k = k + 1
c = c + 1
End If
Case 3
If arr1(jj, 1) Like "*" & arr(0) & "*" Or arr1(jj, 1) Like "*" & arr(1) & "*" Or arr1(jj, 1) Like "*" & arr(2) & "*" Then
Cells(k, i) = arr1(jj, 1)
Range("A" & jj + 2).Font.ColorIndex = 15
k = k + 1
c = c + 1
End If
Case 4
If arr1(jj, 1) Like "*" & arr(0) & "*" Or arr1(jj, 1) Like "*" & arr(1) & "*" Or arr1(jj, 1) Like "*" & arr(2) & "*" Or arr1(jj, 1) Like "*" & arr(3) & "*" Then
Cells(k, i) = arr1(jj, 1)
Range("A" & jj + 2).Font.ColorIndex = 15
k = k + 1
c = c + 1
End If
End Select
End If
End If
Next
If k = 3 Then
l = "暂无"
Cells(h + 3, i) = l
Cells(h + 3, i).Font.ColorIndex = 5
End If
Next
'统计分组个数
s = "总分关键词" & max - 2 & "个" & vbCrLf & "已成功分组" & c & "个" & vbCrLf & "未完成分组" & max - c - 2 & "个"
Range("C" & 1) = s
Range("C" & 1).Font.Size = 9
Application.ScreenUpdating = True '打开屏幕刷新提高运行速度
Range("D1") = "分词耗时：" & Format$(Timer - t, "Fixed") & "s"
Range("E1") = "注：以下词根按照优先级重要程度从左至右，“词根”可根据自身需要自由设置，一列对应一个。另外实现了多个词组合分组（组合格式：北京+快捷+如家），最多四个词"
Call 未分组_keyword '显示未分组
Range("B3:IV65536").Font.Size = 9
End Sub
Sub XXX()
Dim a, b, c, h, i, j, k As Integer
Range("A3:A65536").Font.ColorIndex = 0 '以A3为起点，从左至右，从上至下，区域内的单元格字体颜色为黑色
Range("B3:IV65536").ClearContents '清空，从以B3为起点，从左至右，从上至下，区域内的单元格内容
a = [A65536].End(3).Row '获取A列从第3行开始统计总共有数据的行数，也就是关键词的总个数
b = [iv2].End(xlToLeft).Column '获取第二行，词根行的总个数
c = 0 '获取分组的关键词总个数
For i = 3 To b
h = 0
k = 3
For j = 3 To a
If Cells(j, 1) Like "*" & Cells(2, i) & "*" And Cells(j, 1).Font.ColorIndex <> 15 Then
Cells(k, i) = Cells(j, 1)
Range("A" & j).Font.ColorIndex = 15
k = k + 1
c = c + 1
End If
Next j
If k = 2 Then
l = "暂无"
Cells(h + 2, i) = l
Cells(h + 2, i).Font.ColorIndex = 5
' Else
' h = k - 1
' l = "共有" & (k - 2) & "个关键词"
' Cells(h + 2, i) = l
' Cells(h + 2, i).Font.ColorIndex = 3
End If
Next i
'统计分组个数
s = "总分关键词" & a - 2 & "个" & vbCrLf & "已成功分组" & c & "个" & vbCrLf & "未完成分组" & a - c - 2 & "个"
Range("C" & 1) = s
Range("C" & 1).Font.Size = 9
Call BB
End Sub
Sub 未分组_keyword() '作用是获取未分组的关键词，并显示到第二列
Application.ScreenUpdating = False '关闭屏幕刷新提高运行速度
Dim a, i, k As Integer
a = [A65536].End(3).Row
k = 3
For i = 3 To a
If Range("A" & i).Font.ColorIndex <> 15 Then
Range("B" & k) = Range("A" & i)
k = k + 1
End If
Next i
Application.ScreenUpdating = True '打开屏幕刷新提高运行速度
End Sub
Sub clear() '清空内容并还原颜色
a = [A65536].End(3).Row
Range("B3:IV65536").ClearContents
Range("A3:IV65536").Font.ColorIndex = 1
s = "总分关键词" & a - 2 & "个" & vbCrLf & "已成功分组0个" & vbCrLf & "未完成分组" & a - 2 & "个"
Range("C" & 1) = s
Range("C" & 1).Font.Size = 9
End Sub
Sub clear_one() '清空首列内容并还原颜色
Application.ScreenUpdating = False '关闭屏幕刷新提高运行速度
If MsgBox("你确定要清除【首列总分的所有关键词】？" & vbCrLf & "说明：清除后，关键词完全删除且该操作不可撤销还原，请做好数据备份，慎用！", vbYesNo, "Joy 对清除功能友情提示！") = vbYes Then
Range("A3:A65536").ClearContents
Range("A3:IV65536").Font.ColorIndex = 1
s = "首列总分关键词" & vbCrLf & "已清空！"
Range("C" & 1) = s
Range("C" & 1).Font.Size = 12
End If
Application.ScreenUpdating = True '打开屏幕刷新提高运行速度
End Sub

复制代码

代码太多了，粘贴不了哦，这个是其中一段

Yalishanda30 · 发表于 2018-10-2 16:52

另存为.xlsm格式即可

wanwfy · 发表于 2018-10-2 17:05

Yalishanda30 发表于 2018-10-2 16:52
另存为.xlsm格式即可

谢谢大神！

wanwfy · 发表于 2018-10-2 17:12

Yalishanda30 发表于 2018-10-2 16:52
另存为.xlsm格式即可

刚刚测试了一下，好像不行哦，处理数据的时候没有反应

wanwfy · 发表于 2018-10-2 17:14

wanwfy 发表于 2018-10-2 17:12
刚刚测试了一下，好像不行哦，处理数据的时候没有反应

我处理30多万数据的时候完全没有反应，如果只留下65536行的话就可以正常处理，能不能加个qq帮我看看呢

Yalishanda30 · 发表于 2018-10-2 18:42

wanwfy 发表于 2018-10-2 17:14
我处理30多万数据的时候完全没有反应，如果只留下65536行的话就可以正常处理，能不能加个qq帮我看看呢

这样可以了吗？

wanwfy · 发表于 2018-10-2 19:00

Yalishanda30 发表于 2018-10-2 18:42
这样可以了吗？

wanwfy · 发表于 2018-10-2 19:01

wanwfy 发表于 2018-10-2 19:00

运行以后还是会出现这个错误。

		自动登录	找回密码
密码			免费注册

[求助] 求大神改一个vba代码

评分