[已解决]请老师帮忙写一段宏

DALIANG123

       下面的宏是我在工作表的3008行至3012行的实际操作所录制的。老师们一看就知道。1）BF：BK ；2）复制；3）选择性粘贴；４）数据；５）确定。６）B：C ,向下拖动一行；７）保存。共七个步骤。每一行都重复着上面的七个步骤。手工操作很费时而且很会岀错。请哪位老师帮忙写一段宏，可以一次性完成几千行的工作。十分感谢！期待着你的无私帮助。
       Sub Macro1()
'
' Macro1 Macro
' 宏由 微软用户 录制，时间: 2013-1-6
'
'
    Range("BF3008:BK3008").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("B3008:D3008").Select
    Application.CutCopyMode = False
    Selection.AutoFill Destination:=Range("B3008:D3009"), Type:=xlFillDefault
    Range("B3008:D3009").Select
    ActiveWorkbook.Save
    Range("BF3009:BK3009").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("B3009:D3009").Select
    Application.CutCopyMode = False
    Selection.AutoFill Destination:=Range("B3009:D3010"), Type:=xlFillDefault
    Range("B3009:D3010").Select
    ActiveWorkbook.Save
    Range("BF3010:BK3010").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("B3010:D3010").Select
    Application.CutCopyMode = False
    Selection.AutoFill Destination:=Range("B3010:D3011"), Type:=xlFillDefault
    Range("B3010:D3011").Select
    ActiveWorkbook.Save
    Range("BF3011:BK3011").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("B3011:D3011").Select
    Application.CutCopyMode = False
    Selection.AutoFill Destination:=Range("B3011:D3012"), Type:=xlFillDefault
    Range("B3011:D3012").Select
    ActiveWorkbook.Save
    Range("BF3012:BK3012").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("B3012:D3012").Select
    Application.CutCopyMode = False
    Selection.AutoFill Destination:=Range("B3012:D3013"), Type:=xlFillDefault
    Range("B3012:D3013").Select
    ActiveWorkbook.Save
   
End Sub

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-1-8 09:13

1. Sub 数据()
   
2.     Dim arr, irow&
   
3.     irow = Cells(65536, "BF").End(xlUp).Row
   
4.     If irow < 3008 Then Exit Sub
   
5.     arr = Range("bf3008:bk" & irow).Value
   
6.     Range("bf3008").Resize(UBound(arr), UBound(arr, 2)) = arr
   
7.     Range("b3008:d3008").AutoFill Range("b3008:d" & irow), xlFillDefault
   
8.     MsgBox "操作完成"
   
9. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

你要从哪行开始？最好传个附件，模拟一个效果图来吧。

hwc2ycy

1. Sub 数据()
   
2.     Dim arr, irow&
   
3.     irow = Cells(65536, "BF").End(xlUp).Row
   
4.     If irow < 3008 Then Exit Sub
   
5.     arr = Range("bf3008:bk" & irow).Value
   
6.     Range("bf3008").Resize(UBound(arr), UBound(arr, 2)) = arr
   
7.     Range("b3008:d3008").AutoFill Range("b3008:d" & irow), xlFillDefault
   
8.     MsgBox "操作完成"
   
9. End Sub

复制代码

DALIANG123

hwc2ycy 发表于 2013-1-8 09:13

       谢谢hwc2ycy老师的指教，我套到工作表上试过了。很好用。如果再加上ActiveWorkbook.Save。可以说是十分完美了。再次谢谢hwc2ycy老师!!

hwc2ycy

DALIANG123 发表于 2013-1-8 20:19
谢谢hwc2ycy老师的指教，我套到工作表上试过了。很好用。如果再加上ActiveWorkbook.Save。可以说是 ...

呵呵，漏了，

DALIANG123

hwc2ycy 发表于 2013-1-8 20:20
呵呵，漏了，

        再次请教hwc2ycy老师，每一行保存一次如何加进去?恳请再次教我.

hwc2ycy

DALIANG123 发表于 2013-1-9 10:14
再次请教hwc2ycy老师，每一行保存一次如何加进去?恳请再次教我.

没必要频繁保存吧。最后结束的地方保存就成了。我是一次性把所有的公式转化为数值的，然后再一次写回单元格中。所以不存在每行了。

DALIANG123

hwc2ycy 发表于 2013-1-9 10:32
没必要频繁保存吧。最后结束的地方保存就成了。我是一次性把所有的公式转化为数值的，然后再一次写回单元 ...

        承教了!谢谢!!