循环复制粘贴

qscj

全校有78个班，如果一个一个地复制粘贴，工作量太大，具体要求附件里有，谢谢！

autumnalRain

先收藏下，看看通过POWER QUERY能不能解决。这里的班级直接作为字段而不是作为项

autumnalRain

参考下……

autumnalRain

如果需要严格按你模拟的排列顺序，你可以自定义序列，再排序

zhong1218

1. Sub a()
   
2.     Dim brr(1 To 1500, 1 To 3)
   
3.     brr(1, 1) = "班级": brr(1, 2) = "科目": brr(1, 3) = "教师"
   
4.     arr = Sheets("原始").Range("a1").CurrentRegion
   
5.     For i = 2 To UBound(arr, 2)
   
6.         For j = 2 To UBound(arr)
   
7.             If arr(j, i) <> "" Then
   
8.                 n = n + 1
   
9.                 brr(n + 1, 1) = arr(1, i)
   
10.                 brr(n + 1, 2) = arr(j, 1)
    
11.                 brr(n + 1, 3) = arr(j, i)
    
12.             End If
    
13.         Next j
    
14.     Next i
    
15.     Sheets("整理").Cells.ClearContents
    
16.     Sheets("整理").Range("a1").Resize(UBound(brr), 3) = brr
    
17. End Sub

复制代码

autumnalRain

zhong1218 发表于 2015-11-13 12:16

以前一个老师朋友也问过我这个问题，当时也不会编程序，不会解答，这下也不用编了，直接用了

qscj

zhong1218 发表于 2015-11-13 12:16

非常有用，我还要认真研究这个程序，thanks