[已解决]复制数据并依次递减的问题

dfshm

附件 复制数据到各表A列并依次递减.rar (6.74 KB, 下载次数: 14)

2013-11-29 08:47 上传

点击文件名下载附件
谢谢各位老师。

最佳答案

月排行榜 / 总排行榜

redsheep

2013-11-29 10:05

试试这样的代码

1. Sub test()
   
2. On Error Resume Next
   
3. Application.ScreenUpdating = False
   
4. Set St1 = ThisWorkbook.Sheets.Item(1)
   
5. For i = 2 To WorksheetFunction.Min(St1.Cells(1, St1.UsedRange.Column + St1.UsedRange.Columns.Count).End(xlToLeft).Column, ThisWorkbook.Sheets.Count)
   
6.     For n = 1 To 12
   
7.         St1.Range(St1.Cells(1, i), St1.Cells(St1.Cells(60000, i).End(xlUp).Row - n + 1, i)).Copy
   
8.         Set Stn = ThisWorkbook.Sheets.Item(i)
   
9.         Stn.Paste Destination:=Stn.Cells(n, n)
   
10.     Next
    
11. Next
    
12. Application.CutCopyMode = False
    
13. Application.ScreenUpdating = True
    
14. End Sub

复制代码

跳转到最佳答案楼层

redsheep

试试这样的代码

1. Sub test()
   
2. On Error Resume Next
   
3. Application.ScreenUpdating = False
   
4. Set St1 = ThisWorkbook.Sheets.Item(1)
   
5. For i = 2 To WorksheetFunction.Min(St1.Cells(1, St1.UsedRange.Column + St1.UsedRange.Columns.Count).End(xlToLeft).Column, ThisWorkbook.Sheets.Count)
   
6.     For n = 1 To 12
   
7.         St1.Range(St1.Cells(1, i), St1.Cells(St1.Cells(60000, i).End(xlUp).Row - n + 1, i)).Copy
   
8.         Set Stn = ThisWorkbook.Sheets.Item(i)
   
9.         Stn.Paste Destination:=Stn.Cells(n, n)
   
10.     Next
    
11. Next
    
12. Application.CutCopyMode = False
    
13. Application.ScreenUpdating = True
    
14. End Sub

复制代码

redsheep

有了点小修改
运行速度提高了
列数原来限制是100行 现在不限制了

baksy

来迟了，请试试。
Sub 复制()
x = WorksheetFunction.Count(Range("B:B"))
y = WorksheetFunction.Count(Range("1:1"))
For m = 2 To y + 1
p = Choose(m - 1, "B", "C", "D", "E")
For n = 1 To 12
q = Choose(n, "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L")
Worksheets("sheet1").Range(p & "1:" & p & x).Copy Sheets("Sheet" & m).Range(q & n)
Sheets("Sheet" & m).Range("A" & (x + 1) & ":L" & (x * 2)).Delete
Next n
Next m
End Sub