该vba 多列填充问题,求优化代码和不足
'功能:填充多列数据,如果遇到下一个单元格有内容,则以该单元格作为填充值向下填充SubAutoFill3()Dimi%,a%,bAsString,cAsString,dA...
'功能: 填充多列数据,如果遇到下一个单元格有内容,则以该单元格作为填充值向下填充
Sub AutoFill3()
Dim i%, a%, b As String, c As String, d As String, e As String, f As String, g As String, n As Integer
n = 454 '指定的到第几行
b = "K"
c = "G"
d = "H"
e = "I"
f = "J"
g = "K"
i = Cells(1, b).End(xlUp).Row '定义a列的最后一个单元格,与你原来的代码do……loop类似,
Rng = Cells(1, i) '获取第一列数据
Rng1 = Cells(1, i)
Rng2 = Cells(1, i)
Rng3 = Cells(1, i)
Rng4 = Cells(1, i)
Rng5 = Cells(1, i)
For a = 1 To n '指定填充多少行
If IsEmpty(Cells(a, b)) Then
Cells(a, b) = Rng
ElseIf Len(Cells(a, b)) > 0 Then
Rng = Cells(a, b)
End If
If IsEmpty(Cells(a, c)) Then
Cells(a, c) = Rng1
ElseIf Len(Cells(a, c)) > 0 Then
Rng1 = Cells(a, c)
End If
If IsEmpty(Cells(a, d)) Then
Cells(a, d) = Rng2
ElseIf Len(Cells(a, d)) > 0 Then
Rng2 = Cells(a, d)
End If
If IsEmpty(Cells(a, e)) Then
Cells(a, e) = Rng3
ElseIf Len(Cells(a, e)) > 0 Then
Rng3 = Cells(a, e)
End If
If IsEmpty(Cells(a, f)) Then
Cells(a, f) = Rng4
ElseIf Len(Cells(a, f)) > 0 Then
Rng4 = Cells(a, f)
End If
If IsEmpty(Cells(a, g)) Then
Cells(a, g) = Rng5
ElseIf Len(Cells(a, g)) > 0 Then
Rng5 = Cells(a, g)
End If
Next a
End Sub
当前如果是A ,B ,C ,D 列向下填充,填充行数n改为10 (当前程序可实现,就是看着别扭),则源码需要改动的地方就有 b到g 的变量,以及临时变量 都需要改动。是否有更简洁的方法? 展开
Sub AutoFill3()
Dim i%, a%, b As String, c As String, d As String, e As String, f As String, g As String, n As Integer
n = 454 '指定的到第几行
b = "K"
c = "G"
d = "H"
e = "I"
f = "J"
g = "K"
i = Cells(1, b).End(xlUp).Row '定义a列的最后一个单元格,与你原来的代码do……loop类似,
Rng = Cells(1, i) '获取第一列数据
Rng1 = Cells(1, i)
Rng2 = Cells(1, i)
Rng3 = Cells(1, i)
Rng4 = Cells(1, i)
Rng5 = Cells(1, i)
For a = 1 To n '指定填充多少行
If IsEmpty(Cells(a, b)) Then
Cells(a, b) = Rng
ElseIf Len(Cells(a, b)) > 0 Then
Rng = Cells(a, b)
End If
If IsEmpty(Cells(a, c)) Then
Cells(a, c) = Rng1
ElseIf Len(Cells(a, c)) > 0 Then
Rng1 = Cells(a, c)
End If
If IsEmpty(Cells(a, d)) Then
Cells(a, d) = Rng2
ElseIf Len(Cells(a, d)) > 0 Then
Rng2 = Cells(a, d)
End If
If IsEmpty(Cells(a, e)) Then
Cells(a, e) = Rng3
ElseIf Len(Cells(a, e)) > 0 Then
Rng3 = Cells(a, e)
End If
If IsEmpty(Cells(a, f)) Then
Cells(a, f) = Rng4
ElseIf Len(Cells(a, f)) > 0 Then
Rng4 = Cells(a, f)
End If
If IsEmpty(Cells(a, g)) Then
Cells(a, g) = Rng5
ElseIf Len(Cells(a, g)) > 0 Then
Rng5 = Cells(a, g)
End If
Next a
End Sub
当前如果是A ,B ,C ,D 列向下填充,填充行数n改为10 (当前程序可实现,就是看着别扭),则源码需要改动的地方就有 b到g 的变量,以及临时变量 都需要改动。是否有更简洁的方法? 展开
2个回答
展开全部
最好举个例子说明 开始的状态 和 最后的效果
你的意思是:
A列内,A1填充到下一个有数值的单元格为止(即A3),如果不到n行,继续将A4向下填充,一直到n行为止
对吗?
------------
Sub AutoFill3()
Dim iRng As Range, C As Range, r, rS&, rZ&, col%, dR, rF, tmp
'</*----设置变量--开始--
rS = 1 '指定的开始行
rZ = 454 '指定的结束行
Set iRng = Range("G1,H1,I1,J1,K1") '指定填充的列(中间的数字1不要动,改列标就行了)
'--结束----*/>
Set dR = CreateObject("Scripting.Dictionary")
For Each C In iRng.Cells
col = C.Column
dR.RemoveAll
For r = rS To rZ
If Cells(r, col) <> "" Then dR(r) = ""
Next
If dR.Count > 0 Then
dR(rZ + 1) = ""
rF = dR.keys
For r = LBound(rF) To UBound(rF) - 1
tmp = Val(rF(r + 1)) - Val(rF(r))
If tmp > 1 Then
With Cells(Val(rF(r)), col)
.AutoFill .Resize(tmp), xlFillCopy
End With
End If
Next
End If
Next
End Sub
--------
详细Hi我
你的意思是:
A列内,A1填充到下一个有数值的单元格为止(即A3),如果不到n行,继续将A4向下填充,一直到n行为止
对吗?
------------
Sub AutoFill3()
Dim iRng As Range, C As Range, r, rS&, rZ&, col%, dR, rF, tmp
'</*----设置变量--开始--
rS = 1 '指定的开始行
rZ = 454 '指定的结束行
Set iRng = Range("G1,H1,I1,J1,K1") '指定填充的列(中间的数字1不要动,改列标就行了)
'--结束----*/>
Set dR = CreateObject("Scripting.Dictionary")
For Each C In iRng.Cells
col = C.Column
dR.RemoveAll
For r = rS To rZ
If Cells(r, col) <> "" Then dR(r) = ""
Next
If dR.Count > 0 Then
dR(rZ + 1) = ""
rF = dR.keys
For r = LBound(rF) To UBound(rF) - 1
tmp = Val(rF(r + 1)) - Val(rF(r))
If tmp > 1 Then
With Cells(Val(rF(r)), col)
.AutoFill .Resize(tmp), xlFillCopy
End With
End If
Next
End If
Next
End Sub
--------
详细Hi我
追问
能否将列以字母形式去循环,这样更好些!
追答
字母不合适的,因为超过了Z列后,就是两个字母了,比如 AA列
展开全部
根据你的要求,如下代码即可解决
Sub AutoFill3()
Dim x&, n&,y&
n = Val(InputBox("请输入最大行号(正整数)", "输入", 10)) '指定的到第几行
For x = 1 To n
For y = 1 To 4
If Cells(x, y) = "" Then
Cells(x, y) = Cells(x - 1, y)
End If
Next y
Next x
End Sub
你果你的数据是同一行有数据,还可简化如下
Sub aa()
Dim x&, n&
n = Val(InputBox("请输入最大行号(正整数)", "输入", 10)) '指定的到第几行
For x = 1 To n
If Cells(x, 1) = "" Then
Cells(x - 1, 1).Resize(1, 4).Copy Cells(x, 1)
End If
Next x
End Sub
Sub AutoFill3()
Dim x&, n&,y&
n = Val(InputBox("请输入最大行号(正整数)", "输入", 10)) '指定的到第几行
For x = 1 To n
For y = 1 To 4
If Cells(x, y) = "" Then
Cells(x, y) = Cells(x - 1, y)
End If
Next y
Next x
End Sub
你果你的数据是同一行有数据,还可简化如下
Sub aa()
Dim x&, n&
n = Val(InputBox("请输入最大行号(正整数)", "输入", 10)) '指定的到第几行
For x = 1 To n
If Cells(x, 1) = "" Then
Cells(x - 1, 1).Resize(1, 4).Copy Cells(x, 1)
End If
Next x
End Sub
已赞过
已踩过<
评论
收起
你对这个回答的评价是?
推荐律师服务:
若未解决您的问题,请您详细描述您的问题,通过百度律临进行免费专业咨询