高手帮忙用VBA来处理此EXCEL
答案:6 悬赏:60 手机版
解决时间 2021-03-02 23:41
- 提问者网友：风月客
- 2021-03-02 08:55
高手帮忙用VBA来处理此EXCEL
最佳答案
- 五星知识达人网友：笑迎怀羞
- 2021-03-02 09:58
Sub aa()
With ActiveSheet
sta = 4
irow = .Range("A65536").End(xlUp).Row
For i = sta To irow
If .Cells(i, 7) = "" Then
tmp = Replace(.Cells(i, 1), " ", "") & "."
k = Len(tmp)
Formula1 = ""
For j = sta To irow
If Left(Replace(.Cells(j, 1), " ", ""), k) = tmp Then
If InStr(Mid(Replace(.Cells(j, 1), " ", ""), k + 1), ".") = 0 Then Formula1 = Formula1 & "+H" & j
End If
Next j
If Len(Formula1) > 1 Then Mid(Formula1, 1, 1) = "="
.Cells(i, 7) = Formula1 '写入公式
.Cells(i, 7).Interior.ColorIndex = 3 '设置红色底色
End If
Next i
End With
End Sub
经过修改:
Sub aa()
With ActiveSheet
sta = 4
flag = False
irow = .Range("A65536").End(xlUp).Row
For i = sta To irow
.Cells(i, 1) = Replace(.Cells(i, 1), " ", "")
Next i
For i = sta To irow
tmp = .Cells(i, 1) & "."
k = Len(tmp)
Formula1 = ""
For kk = i To irow
If InStr(.Cells(kk, 1), tmp) = 1 Then flag = True: Exit For
Next kk
If flag Then
For j = sta To irow
If Left(.Cells(j, 1), k) = tmp Then
If InStr(Mid(.Cells(j, 1), k + 1), ".") = 0 Then Formula1 = Formula1 & "+H" & j
End If
Next j
If Len(Formula1) > 1 Then Mid(Formula1, 1, 1) = "="
.Cells(i, 7) = Formula1 '写入公式
.Cells(i, 7).Interior.ColorIndex = 3 '设置红色底色
flag = False
End If
Next i
End With
End Sub
With ActiveSheet
sta = 4
irow = .Range("A65536").End(xlUp).Row
For i = sta To irow
If .Cells(i, 7) = "" Then
tmp = Replace(.Cells(i, 1), " ", "") & "."
k = Len(tmp)
Formula1 = ""
For j = sta To irow
If Left(Replace(.Cells(j, 1), " ", ""), k) = tmp Then
If InStr(Mid(Replace(.Cells(j, 1), " ", ""), k + 1), ".") = 0 Then Formula1 = Formula1 & "+H" & j
End If
Next j
If Len(Formula1) > 1 Then Mid(Formula1, 1, 1) = "="
.Cells(i, 7) = Formula1 '写入公式
.Cells(i, 7).Interior.ColorIndex = 3 '设置红色底色
End If
Next i
End With
End Sub
经过修改:
Sub aa()
With ActiveSheet
sta = 4
flag = False
irow = .Range("A65536").End(xlUp).Row
For i = sta To irow
.Cells(i, 1) = Replace(.Cells(i, 1), " ", "")
Next i
For i = sta To irow
tmp = .Cells(i, 1) & "."
k = Len(tmp)
Formula1 = ""
For kk = i To irow
If InStr(.Cells(kk, 1), tmp) = 1 Then flag = True: Exit For
Next kk
If flag Then
For j = sta To irow
If Left(.Cells(j, 1), k) = tmp Then
If InStr(Mid(.Cells(j, 1), k + 1), ".") = 0 Then Formula1 = Formula1 & "+H" & j
End If
Next j
If Len(Formula1) > 1 Then Mid(Formula1, 1, 1) = "="
.Cells(i, 7) = Formula1 '写入公式
.Cells(i, 7).Interior.ColorIndex = 3 '设置红色底色
flag = False
End If
Next i
End With
End Sub
全部回答
- 1楼网友：煞尾
- 2021-03-02 13:02
高手帮忙用VBA来处理此EXCEL
或许放弃才是最美丽的结局。
或许放弃才是最美丽的结局。
- 2楼网友：底特律间谍
- 2021-03-02 12:52
cctv1102, 请将此句改一下, 使它在有内容(值)时也能运行
If .Cells(i, 7) = "" Then
If .Cells(i, 7) = "" Then
- 3楼网友：冷風如刀
- 2021-03-02 12:26
上面的回答没有理解你的问题。
你这个分为1、2、3、4……等多层，然后每一层中还有子层，就是树形目录结构。所以关键是要确定层和子层，如1和1.1、1.2、1.3、1.4,1.5等，1=1.1+1.2+1.3+1.4+1.5……，1.3和1.3.1、1.3.2、1.3.3等，以此类推，这样一分析就很简单了，代码写出来不算少的，要先遍历A列，确定总层数要判断A列的值，这里运用的是字符串的比对，是否包含某个字符串，比如值为1，那么就往下找1.1，找到就读取H列的对应值，再找1.2等等，思路大概就是这样，不难。为避免人为的输入错误，A列应添加有效性下拉列表，选择填入，以免运行出错。
你这个分为1、2、3、4……等多层，然后每一层中还有子层，就是树形目录结构。所以关键是要确定层和子层，如1和1.1、1.2、1.3、1.4,1.5等，1=1.1+1.2+1.3+1.4+1.5……，1.3和1.3.1、1.3.2、1.3.3等，以此类推，这样一分析就很简单了，代码写出来不算少的，要先遍历A列，确定总层数要判断A列的值，这里运用的是字符串的比对，是否包含某个字符串，比如值为1，那么就往下找1.1，找到就读取H列的对应值，再找1.2等等，思路大概就是这样，不难。为避免人为的输入错误，A列应添加有效性下拉列表，选择填入，以免运行出错。
- 4楼网友：洒脱疯子
- 2021-03-02 11:11
'Option Explicit
Sub 宏1()
'
' 宏1 Macro
' user 记录的宏 2011-4-7
'
'
Sheets("VBA执行前").Select
Columns("A:H").Select
Range("H1").Activate
Selection.Copy
Sheets("VBA执行后").Select
Range("A1").Select
ActiveSheet.Paste
i23 = [a65536].End(xlUp).Row: k100 = 100
For i = 4 To i23
If Cells(i, 7) = "" Then
crci = Cells(i, 1) & ".": k = Len(crci): gyui = ""
For j = 4 To i23
If Left(Cells(j, 1), k) = crci Then
If InStr(1, Mid(Cells(j, 1), k + 1, k100), ".") = 0 Then gyui = gyui & "+h" & j
End If
Next j
If Len(gyui) > 1 Then Mid(gyui, 1, 1) = "="
Cells(i, 7) = gyui
End If
Next i
End Sub追问谢谢， 不行啊追答请先将A列的空格替换成没有空格
中央电视台102 已经将空格处理放在了宏内。运行结果正确。请查收。
NG_677步兵骑士 六级 纯粹是胡说八道！
Sub 宏1()
'
' 宏1 Macro
' user 记录的宏 2011-4-7
'
'
Sheets("VBA执行前").Select
Columns("A:H").Select
Range("H1").Activate
Selection.Copy
Sheets("VBA执行后").Select
Range("A1").Select
ActiveSheet.Paste
i23 = [a65536].End(xlUp).Row: k100 = 100
For i = 4 To i23
If Cells(i, 7) = "" Then
crci = Cells(i, 1) & ".": k = Len(crci): gyui = ""
For j = 4 To i23
If Left(Cells(j, 1), k) = crci Then
If InStr(1, Mid(Cells(j, 1), k + 1, k100), ".") = 0 Then gyui = gyui & "+h" & j
End If
Next j
If Len(gyui) > 1 Then Mid(gyui, 1, 1) = "="
Cells(i, 7) = gyui
End If
Next i
End Sub追问谢谢， 不行啊追答请先将A列的空格替换成没有空格
中央电视台102 已经将空格处理放在了宏内。运行结果正确。请查收。
NG_677步兵骑士 六级 纯粹是胡说八道！
参考资料：请先将A列的空格替换成没有空格
- 5楼网友：举杯邀酒敬孤独
- 2021-03-02 10:09
sxpose 23:57:33
ok了
0:03:00
文件 “VBA 根据层数求和，写入求和公式.xls”(36KB)已成功上传至服务器，我们将为您的好友保存 7 天。
-------------
Public Sub ssss()
'根据层数求和，写入求和公式
Dim c1%, c2%, c3%, rs&, re&
c1 = 1 '搜索列位置
c2 = 8 '数据列位置
c3 = 7 '写入公式列位置
rs = 4 '起始行位置
re = Cells(65536, c1).End(xlUp).Row '结束行位置
Dim c As Range, s$, Add1$, fml$, t As Boolean, i&, fRng As Range
For i = rs To re
s = Cells(i, c1).Value
Set fRng = Range(Cells(i, c1), Cells(re, c1))
Set c = fRng.Find(
……
……
详细见离线文件，点按钮运行
你可以改下层数试试
ok了
0:03:00
文件 “VBA 根据层数求和，写入求和公式.xls”(36KB)已成功上传至服务器，我们将为您的好友保存 7 天。
-------------
Public Sub ssss()
'根据层数求和，写入求和公式
Dim c1%, c2%, c3%, rs&, re&
c1 = 1 '搜索列位置
c2 = 8 '数据列位置
c3 = 7 '写入公式列位置
rs = 4 '起始行位置
re = Cells(65536, c1).End(xlUp).Row '结束行位置
Dim c As Range, s$, Add1$, fml$, t As Boolean, i&, fRng As Range
For i = rs To re
s = Cells(i, c1).Value
Set fRng = Range(Cells(i, c1), Cells(re, c1))
Set c = fRng.Find(
……
……
详细见离线文件，点按钮运行
你可以改下层数试试
我要举报
如以上回答内容为低俗、色情、不良、暴力、侵权、涉及违法等信息，可以点下面链接进行举报！
点此我要举报以上问答信息
大家都在看
推荐资讯