[已解决]求大神请教，将有红色填充表格所在行录入新表，有合并单元格

ynslyjb · 发表于 2012-10-8 17:09

要求将表1（sheet"食品企业评定标准"）中D栏（标准分值）被红色填充所在行的内容录入表3（扣分说明）中。其中表一A列、B列有合并单元格。
小弟不才写了下代码（已在附件中），感觉没有问题了，但是运行不出来。
求大神赐教，看看哪里出问题了，有新代码欢迎交流。
遇到死循环的话按Ctrl+Break可以强制退出代码运行。

最佳答案

月排行榜 / 总排行榜

hrpotter

2012-10-8 17:51

Sub test()
Dim i As Long, j As Long, k As Long
Dim arr, brr(1 To 10000, 1 To 8)
With Sheets("食品企业评定标准")
arr = .Range("a1").CurrentRegion
For i = 2 To UBound(arr)
If arr(i, 1) = "" Then arr(i, 1) = arr(i - 1, 1)
If arr(i, 2) = "" Then arr(i, 2) = arr(i - 1, 2)
If .Cells(i, 4).Interior.ColorIndex = 3 Then
k = k + 1
For j = 1 To 8
brr(k, j) = arr(i, j)
Next
End If
Next
End With
With Sheets("扣分说明")
.Range("a2:h65536").Clear
If k > 0 Then
With .Range("a2").Resize(k, 8)
.Value = brr
.Borders.LineStyle = 1
.WrapText = True
.Rows.AutoFit
End With
End If
End With
End Sub

复制代码

跳转到最佳答案楼层

hrpotter · 发表于 2012-10-8 17:51

这个最佳答案由 hrpotter 给出，感谢 hrpotter 的回答。

单击隐藏图章

Sub test()
Dim i As Long, j As Long, k As Long
Dim arr, brr(1 To 10000, 1 To 8)
With Sheets("食品企业评定标准")
arr = .Range("a1").CurrentRegion
For i = 2 To UBound(arr)
If arr(i, 1) = "" Then arr(i, 1) = arr(i - 1, 1)
If arr(i, 2) = "" Then arr(i, 2) = arr(i - 1, 2)
If .Cells(i, 4).Interior.ColorIndex = 3 Then
k = k + 1
For j = 1 To 8
brr(k, j) = arr(i, j)
Next
End If
Next
End With
With Sheets("扣分说明")
.Range("a2:h65536").Clear
If k > 0 Then
With .Range("a2").Resize(k, 8)
.Value = brr
.Borders.LineStyle = 1
.WrapText = True
.Rows.AutoFit
End With
End If
End With
End Sub

复制代码

ynslyjb · 发表于 2012-10-8 17:56

hrpotter 发表于 2012-10-8 17:51

你好，谢谢，但是我还是不知道怎么才能运算出结果，麻烦告诉一下吧

hrpotter · 发表于 2012-10-8 18:06

ynslyjb 发表于 2012-10-8 17:56
你好，谢谢，但是我还是不知道怎么才能运算出结果，麻烦告诉一下吧

把上述代码复制到你的vbe编辑器的模块1里，然后点运行就可以了！

ynslyjb · 发表于 2012-10-8 18:59

hrpotter 发表于 2012-10-8 18:06
把上述代码复制到你的vbe编辑器的模块1里，然后点运行就可以了！

成功了，大神犀利。请问你是做什么的呢？这东西我弄了两周没弄好，你几分钟就搞定了，厉害的很呐！

ynslyjb · 发表于 2012-10-8 19:31

hrpotter 发表于 2012-10-8 18:06
把上述代码复制到你的vbe编辑器的模块1里，然后点运行就可以了！

大神，我运行后表2（评分汇总）的内容全部变成了#######，得按F9才能正常显示，有没有什么办法可以解决这个问题呢？

hrpotter · 发表于 2012-10-8 19:40

ynslyjb 发表于 2012-10-8 19:31
大神，我运行后表2（评分汇总）的内容全部变成了#######，得按F9才能正常显示，有没有什么办法可以解决这 ...

Sub test()
Dim i As Long, j As Long, k As Long
Dim arr, brr(1 To 10000, 1 To 8)
Application.Calculation = xlCalculationManual '加这个
With Sheets("食品企业评定标准")
arr = .Range("a1").CurrentRegion
For i = 2 To UBound(arr)
If arr(i, 1) = "" Then arr(i, 1) = arr(i - 1, 1)
If arr(i, 2) = "" Then arr(i, 2) = arr(i - 1, 2)
If .Cells(i, 4).Interior.ColorIndex = 3 Then
k = k + 1
For j = 1 To 8
brr(k, j) = arr(i, j)
Next
End If
Next
End With
With Sheets("扣分说明")
.Range("a2:h65536").Clear
If k > 0 Then
With .Range("a2").Resize(k, 8)
.Value = brr
.Borders.LineStyle = 1
.WrapText = True
.Rows.AutoFit
End With
End If
End With
Application.Calculation = xlCalculationAutomatic '加这个
End Sub

复制代码

ynslyjb · 发表于 2012-10-9 18:32

hrpotter 发表于 2012-10-8 19:40

好像不行额，大神

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

[已解决]求大神请教，将有红色填充表格所在行录入新表，有合并单元格

相关帖子