数据按条件自动填充（颇有难度，请老师关注）

kandhong

老师：
   我想请教的问题是：数据按条件自动填充。
   思路如下：
   按下“自动生成”按键
   自动在I18中填入数字1，同时将R列数据填入到V列；
   自动在I18中填入数字2，同时将R列数据填入到W列；
   自动在I18中填入数字3，同时将R列数据填入到X列；
   自动在I18中填入数字4，同时将R列数据填入到Y列；
   自动在I18中填入数字5，同时将R列数据填入到Z列。
   一直循环至填入数字40。
  
   再一次感谢老师！！
    颇有难度的填充问题.rar (7.55 KB, 下载次数: 5)

2015-1-8 14:37 上传

点击文件名下载附件
   

suye1010

1. Option Explicit
   
2. 
   
3. Sub Test()
   
4. Dim i
   
5. For i = 1 To 40
   
6.     Range("I18") = i
   
7.     Range("R1:R65536").Copy Range("R1").Offset(, 3 + i)
   
8. Next i
   
9. End Sub

复制代码

xdragon

1. Sub test()
   
2. '    Columns("R").copy Columns("U").Offset(0, [I18])
   
3.     Columns("R").Copy Columns("V").Resize(, [I18])
   
4. End Sub

复制代码

不知道是不是根据i18去扩展列的，如果不是把[i18]改成40就可以了

爱疯

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$I$18" Then
        Application.DisplayAlerts = False
        [r4:r23].Copy [u4].Offset(0, Target)
        Application.DisplayAlerts = True
    End If
End Sub
颇有难度的填充问题2.rar (11.99 KB, 下载次数: 5)

2015-1-8 16:46 上传

点击文件名下载附件

爱疯

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$I$18" Then
        Application.DisplayAlerts = False
        [r4:r23].Copy [v4].Resize(1, 40) '是复制到整个区域？
        Application.DisplayAlerts = True
    End If
End Sub

kandhong

suye1010 发表于 2015-1-8 15:40

suye1010 老师：
    您的大作已拜读，效果完美！
    在测试中发现一个问题：
    当R列是文本或纯数字时，VBA发挥完美；
    当R列用公式取数时（如：R4=a1[a1中有数据]）,VBA作用失效，显示的不是数字，而是公式。
    suye1010 老师老师，这个问题不知能否给予解决！！
    问题附件.rar (16.63 KB, 下载次数: 5)

2015-1-8 17:41 上传

点击文件名下载附件