[已解决]请论坛老师帮我写段代码。

yslvictor · 发表于 2013-3-9 22:36

本帖最后由 yslvictor 于 2013-3-9 22:48 编辑

我初学vba，请论坛老师写一段代码。
条件是：从行4703开始计算直到行4802行结束。
            如果BY4703和BZ4703同时不大于0，则BW4703等于0，否则等于1；
            如果BY4704和BZ4704同时不大于0，则BW4704等于0，否则等于1；
            如果BY4705和BZ4705同时不大于0，则BW4705等于0，否则等于1；
            …………………………………
            以此类推直到
         如果BY4802和BZ4802同时不大于0，则BW4802等于0，否则等于1；
（函数我会，我想用vba。因为函数的公式如果太多的话会占用内存，再运行其他程序速度减慢）。
   先谢谢了。
如图：

用vba根据条件写段代码.rar (32.94 KB, 下载次数: 4)

那么的帅 · 发表于 2013-3-9 22:41

提供数据附件，并举例说明要达到的效果

hwc2ycy · 发表于 2013-3-9 22:47

Sub 填充()
Dim arr, arr2()
Dim i As Integer
arr = Range("by4703:bz4802")
ReDim arr2(1 To UBound(arr), 1 To 1)
For i = LBound(arr) To UBound(arr)
If arr(i, 1) < 0 And arr(i, 2) < 0 Then
arr2(i, 1) = 0
Else
arr2(i, 1) = 1
End If
Next
Range("bw4703").Resize(UBound(arr2)) = arr2
End Sub

复制代码

hwc2ycy · 发表于 2013-3-9 22:49

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

单击隐藏图章

[code]Sub 填充()
Dim arr, arr2()
Dim i As Integer
arr = Range("by4703:bz4802")
ReDim arr2(1 To UBound(arr), 1 To 1)
For i = LBound(arr) To UBound(arr)
If arr(i, 1) < =0 And arr(i, 2) < =0 Then
arr2(i, 1) = 0
Else
arr2(i, 1) = 1
End If
Next
Range("bw4703").Resize(UBound(arr2)) = arr2
End Sub

复制代码

[/code]

不大于应该是小于等于吧。

那么的帅 · 发表于 2013-3-9 22:54

Sub fgf()
Dim arr, arr2()
Dim i As Integer
arr = Range("by4703:bz4802")
ReDim arr2(1 To UBound(arr), 1 To 1)
For i = LBound(arr) To UBound(arr)
If arr(i, 1) > 0 Or arr(i, 2) > 0 Then
arr2(i, 1) = 1
Else
arr2(i, 1) = 0
End If
Next
Range("bw4703").Resize(UBound(arr2)) = arr2
End Sub

复制代码

yslvictor · 发表于 2013-3-9 22:56

谢谢hwc2ycy论坛老师，你在4楼写的代码就是我要的。

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