[资料转载]VBA入门学习 [复制链接]

二、实例
    实例1：如下图，B列的单元格b2是表头，从B3起每个单元格里面有长度不等的数据，这些数据由数字、汉子、英语字母等等混合而成，而且行数不定。要求将数字提取到相应的C列单元格中。
    先来看看平时我们手工下是如何做的：从第一个字符开始只要看到某个字符是0123456789这十个字符中的任何一个就把他写到C3单元格，直到将一个单元格的字符看完为此。因此B3单元格的第3、第4、第6、第7、第10、第11 个字符是，写到C3就成了431367，B3就整完成了，下一个单元格又重头来，再下一个单元格又重头来，……不就是加循环吗？。
    换成程序由电脑来做，实际上与我们人脑做是一样，以下是将此过程翻译成代码：
Sub qushu_1()         '程序名称为qushu_1
Dim i1%, i2%, s_tmp$  '定义两个整型变量i1、i2和一个字符串临时变量s_tmp
i1 = 3                'B列数据是从B3开始的，所以变量i1的初值为3
Do While Cells(i1, 2) <> ""   '如果B列的第i1个单元格不为空则执行循环
   Cells(i1, 3) = ""    '先把C列的目的单元格清空。
   For i2 = 1 To Len(Cells(i1, 2))   'i2从第一个字符循环到最后一个字符
       s_tmp = Mid(Cells(i1, 2), i2, 1)  '将第i2个字符取出来赋给变量s_tmp
       If s_tmp = "0" Or s_tmp = "1" Or s_tmp = "2" Or s_tmp = "3" Or s_tmp = "4" Or s_tmp = "5" Or s_tmp = "6" Or s_tmp = "7" Or s_tmp = "8" Or s_tmp = "9" Then
            Cells(i1, 3) = Cells(i1, 3) & s_tmp
      End If
   Next   '下一个字符
   i1 = i1 + 1   '下一个单元格
Loop
End Sub
    怎么样？看得明白嘛？按F8键单步执行一下看看。代码的写法与我们人工的做法在顺序上稍微有点调换，但总体上还是按我们人工做法来做的。
    不过，这段代码有个地方还是感觉怪怪的，那就是条件语句中的条件部份，这里还仅仅是10个数字，要是是26个英语字母不是还要写好长好长？虽然他显示出多个条件任意满足一个时可以这样表达，但在此处必须得改！
If s_tmp = "0" Or s_tmp = "1" Or s_tmp = "2" Or s_tmp = "3" Or s_tmp = "4" Or s_tmp = "5" Or s_tmp = "6" Or s_tmp = "7" Or s_tmp = "8" Or s_tmp = "9" Then
可以改为以下几种都是可以的：
If InStr("0123456789", s_tmp) > 0 Then
If val(s_tmp)>=0 Then
If s_tmp Like "[0-9]"  Then
   慢慢体会吧。
   这样写虽然可以达到目的，可是当b列中要处理的单元格多时，那个速度够你受的。才说了数组，我们思路不变，只是换成数组看看：
   先加一些积木块：
   因为B列数据不晓得填到哪一行了，我们得先找到B列最后一个有数据的单元格是哪个：range("b65536").end(xlup)，找行的话用range("b65536").end(xlup).row
   将单元格区域的值赋给数组：动态数组=单元格区域；反之：单元格区域=数组。其中单元格区域可用resize(行数,列数)来调整区域的大小（增大或缩小都可以，只要不要成为0或负数就行）
   取数组的最大/最小下标:ubound(数组[,维数])/ lbound(数组[,维数]) 维数省略时为第一维
Sub qushu_2()
Dim i1%, i2%, s_tmp1$, s_tmp2$
Dim arr1()   '定义动态数组arr1
arr1 = Range("b3:b" & Range("b65536").End(xlUp).Row) '从B3开始到B列最后一个单元格的数据赋给数组变量arr1
i1 = 1
Do While i1 <= UBound(arr1)   '这两句就是i从1循环到数组arr1第一维的最大下标
'以上两句也可改成for i1=1 to UBound(arr1)，当然后面的loop得相应改成next
   For i2 = 1 To Len(arr1(i1, 1))
       s_tmp1 = Mid(arr1(i1, 1), i2, 1)
       If s_tmp1 Like "[0-9]" Then  '这里采用了前例中的一种写法
          s_tmp2 = s_tmp2 & s_tmp1
       End If
   Next
   arr1(i1, 1) = s_tmp2   '把数字写回数组
   s_tmp2 = ""            '把s_tmp2清空。可是为什么要这么做呢？
   i1 = i1 + 1
Loop
Range("c3:c" & Range("b65536").End(xlUp).Row) = arr1 '把数组写回C3开始的单元格区域
'也可以写成Range("c3").resize(i1-1) = arr1,可是为什么i1-1呢？
End Sub
   体验下改代码：
   要是把s_tmp2 = s_tmp2 & s_tmp1改成s_tmp2 = s_tmp1 & s_tmp2结果是什么？要是把要求改成取非数字又该如何改代码？等等，大家自己去试去想吧
---------------------------------------------------------------------------------------------
例2：如下图，从B3单元格开始（行数不定），里面的数据是由数字和字母组成，要求在C列单元格生成其不重复的字符串。

还是先来看在手工下我们如何来做：B3单元格，第一个是t，先把它写到C3中；第二还是t，一看C3中已经有了，那就不要它；第三个是6,C3中没有，写入C3；……其余单元格，加循环就可以了。就这么简单，下来的事情就仅仅是将刚才的翻译成代码而已：
Sub qucf_1()
Dim i1%, i2%, s_tmp$
i1 = 3
Do While Cells(i1, 2) <> ""
   Cells(i1, 3) = ""
   For i2 = 1 To Len(Cells(i1, 2))
       s_tmp = Mid(Cells(i1, 2), i2, 1)
       If InStr(Cells(i1, 3), s_tmp) < 1 Then
          Cells(i1, 3) = Cells(i1, 3) & s_tmp
       End If
   Next
   i1 = i1 + 1
Loop
End Sub
    不就是例1的代码吗？只有点小区别：If InStr(Cells(i1, 3), s_tmp) < 1 Then与If InStr(Cells(i1, 3), s_tmp) >0 Then，能理解吧？可见，代码稍改一点，实现的功能就可能大相径庭！至于改成数组，大家自己动动手吧。
    阅读并解释代码也是训练。下面再提供一段代码，大家自己写写其思路：
Sub qucf_2()
Dim i1%, s_tmp1$, s_tmp2$
i1 = 3
Do While Cells(i1, 2) <> ""
   s_tmp1$ = Cells(i1, 2)
   Do While Len(s_tmp1$) > 0
      s_tmp2 = Left(s_tmp1$, 1)
      Cells(i1, 3) = Cells(i1, 3) & s_tmp2
      s_tmp1 = Replace(s_tmp1, s_tmp2, "")
   Loop
   i1 = i1 + 1
Loop
End Sub
坛子中有很多讲排序的代码，但同时也有很多在问排序的，都说排序代码不好理解。其实排序和我们前面讲的也一样，就是把我们平时日常生活中是如何做的翻译成代码而已。下面我们就来说说教科书上讲的几个排序算法（下面讲的时候以3   5    4    6    2    1这六个数最终排为1    2   3   4    5    6为例，但代码中需排序的数据源在当前表的a1到a100单元格中，结果依次放在b列、c列……）：
一、选择排序：
    我们在日常生活中，常用的办法是先从一堆数中找出最小的放在第一位，再在余下的数中找出最小的放在第二位……以此类推，这种排序就叫选择排序。我们详细来说说其过程：
第一遍：用第一个数依次与第二个数、第三个数等等比较，只要是比第一个数小，则将它与第一个数交换，这样第一个数就是最小的了，其过程如下图：

    第二遍：用第二个数依次与第三个数、第四个数等等比较，只要是比第二个数小，则将它与第二个数交换，这样第二个数就是次小的了。过程中显然5和4交换、4和6不换、4和3交换、3和2交换，结果为1   2   5   6   4   3  
        第三遍：用第三个数……
    以此类推，直到所有的数都排好为止。现在我们来将他翻译成相应的代码：
Sub xzpx1()   '选择排序
Dim ar()
ar = Range("a1:a100").Value
For i& = 1 To 99
    For j& = i + 1 To 100
      If ar(i, 1) > ar(j, 1) Then
         tmp% = ar(i, 1)
         ar(i, 1) = ar(j, 1)
         ar(j, 1) = tmp
      End If
    Next
Next
[b1:b100] = ar
End Sub
    但这样一来，交换的次数有点多，而且其思路还是有点不好理解，可以稍改一下(我们就省略了，只写第一遍的，其余类推)：记下第一个数的值和他处的位置（第一个数当然是第一了），用这个数依次与后面的数比较，当有比他小的数出现时，记下这个小的数及其所处的位置，然后用这个小的数与后面的比较，反复执行直到所有的数都比较完成了，这样得到两个东西：最小的数和他所处的位置，这时我们就将第一个数和这个最小的数进行交换。这样第一个数就排好了，然后再类似地排第二个数、第三个数。代码如下：
Sub xzpx2()   '选择排序2
ar = Range("a1:a100").Value
For i& = 1 To 99
   n_min% = ar(i, 1)     '用n_min记下当前的数值
   mrow = i          '用mrow记下n_min所处的位置
      For k% = i + 1 To 100
         If n_min > ar(k, 1) Then '如果有比n_min小的数
            n_min = ar(k, 1) '则将该数赋给n_min
            mrow = k '同时用mrow记下该数所处的位置
         End If
      Next
    If mrow <> i Then '不相等说明循环过程中给n_min赋过新值
       ar(mrow, 1) = ar(i, 1) '则进行交换
       ar(i, 1) = n_min
    End If
Next
[c1:c100] = ar
End Sub
这个代码引入了新的变量n_min，其实可以不用它都可以，而直接用以下代码完全一样：
Sub xzpx3()  '选择排序3
Dim ar()
ar = Range("a1:a100").Value
For i& = 1 To 99
    mrow& = i  '用mrow记下n_min所处的位置
    For j& = i + 1 To 100
      If ar(mrow, 1) > ar(j, 1) Then '用mrow指向的数来作比较
          mrow = j '用mrow记下较小数的位置
      End If
    Next
    If mrow <> i Then 'mrow与i值不同说明上面的循环中有比第i个数小的数，交换
       tmp% = ar(i, 1)
       ar(i, 1) = ar(mrow, 1)
       ar(mrow, 1) = tmp
    End If
Next
[d1:d100] = ar
End Sub
    选择排序与我们日常生活非常接近，是最易理解的排序方法。同时缺点也非常明显：数据量小还行，数据稍多点，速度太慢太慢。
--------------------------------------------------------------------------------------
为此程序语言中人们又想出了以下的排序方法：
二、插入排序：就是把数据插入到前面已排好的数据中。这种方法是从第二个数开始：
直接插入排序：第一个数认为是排好了的（只有一个数，当然是排好了的），所以就从第二个数开始：把第二个数插入到前面已排好的序列中，由于此时前面只有一个数，所以就这两数比较来决定插入到第一个数的前面还是后面，这样第一、第二个数就排好了；把第三个数插入到前面已排好的序列中……直到所有的数都排好为此。具体过程见下图所示：

Sub crpx1()     '直接插入排序
Dim ar()
ar = Range("a1:a100").Value
For i% = 2 To 100  '注意与前面的选择排序的不同，是从第二个数到最后一个
   tem% = ar(i, 1)
   For k% = i - 1 To 1 Step -1  '这里用上了倒循环。也可改成do循环
     If tem < ar(k, 1) Then
        ar(k + 1, 1) = ar(k, 1)
     Else
        Exit For  '这是异常跳出for循环，而执行next后面的语句
     End If
  Next
  ar(k + 1, 1) = tem
Next
[e1:e100] = ar
End Sub
    可见直接插入排序是在排第k个数时，前边的k-1个是已排好的，只需要将第k个数插入到前面k-1个数的合适位置就行了，采取的办法是将第k个数与前面的k-1个数倒起来比较，比他大的都往后移，当找到比他小的数的时候则终止比较（即找到他应该处的位置了）并将他写入。
    对他的改进方法是：采用二分法来查找他该处的位置，其余与直接插入相同。具体方法是：在排第k+1个数时，前边的k个数已排好，我们不必要从后往前一个一个的来比较，而是拿这个第k+1个数与已排好的k个数中的中间那个数（即第k/2个数）进行比较，根据其大小来确定这个数是插入到排好的k个数的前半区还是后半区，这样比较一次其范围就缩小一半，然后'再对这个半区再做前面的操作来再缩小一半……直到确定唯一位置后再将其插入。
Sub crpx2()    '二分法直接插入排序
Dim ar()
ar = range(“a1:a100”).Value
For i% = 2 To 100
   tem% = ar(i, 1)
   lo% = 1
   u% = i - 1
   Do While lo <= u‘此循环用于折半（称二分法）查找，请注意变量的设置、处理的技巧
        m% = Int((lo + u) / 2)‘求中间数
        If tem <ar(m, 1) Then‘确定下一个查找的区域
             u = m - 1
       Else
            lo = m + 1
       End If
    Loop
    For k = i - 1 To lo Step -1‘此循环用于将大数依次往后移动，以便腾出空位让新数插入。
         ar(k + 1, 1) = ar(k, 1)
    Next
   ar(lo, 1) = tem ‘插入新数
Next
[f1:f100] = ar
End Sub
    这一方法的难点是二分法部份（当中的do循环部份），仔细体会。
----------------------------------------------------------------------------------

还是下回再传吧！

谢谢楼主，希望有帮助

今天把它发布完，今后这类东东还是发附件痛快些！


三、冒泡排序
    也称大数下沉。第一遍的过程：第一、二两个数比较，如果第一个数大，则交换否则不换；第二、三个数比较，如果第二个数大，则交换否则不换；第三、四个数比较，如果第三个数大，则交换否则不换；……最后两个数比较，倒数第二个数大则交换否则不换。这样最大的数就被一步步的换到了最后一个位置。第二遍的过程：与第一遍相同，只是到比较的个数少一个（最后一个不比较，因为他已经是最大的了），这样次大的数就被一步步的换到了倒数第二的位置。以此类推，直到所有的都进行完成则数就排好了。特别是：如果某遍比较过程中，如果没有进行过数据交换，则说明数据已提前排好，可以结束比较了。这一思路的代码如下：
Sub mppx()  '冒泡排序1
Dim ar(),fla as boolean
ar = range(“a1:a100”).Value
For i% = 1 To 99
    fla = True   ‘这一变量用来做标志，初值为真
    For k% = 1 To 100-i
          If ar(k, 1) >ar(k + 1, 1) Then‘如果需要进行交换
                fla = False‘则标志变量为假
               tem% = ar(k, 1)‘进行交换
               ar(k, 1) = ar(k + 1, 1)
               ar(k + 1, 1) = tem
          End If
     Next
     If fla Then Exit For‘如果标志变量为真，说明这一遍循环没有数据进行交换，则退出
Next
[g1:g100] = ar
End Sub
    设置了标志变量后，当待排数据大部有序时起到了非常大的作用。但同时，待排数据大部有序时内层循环还是嫌执行多了，为此又有了改进做法：再设置一个变量，用于记录内层循环最后一个进行过数据交换的位置，此位置之后的数据没进行过交换，说明他们都已排好了，为此下一回进行数据比较交换时已排好的就不需要再进行比较了嘛，也就是说循环只需到上回最后一个进行过数据交换的位置就行了。实现这一思想的代码如下：
Sub mppx2()    '冒泡排序2
Dim ar(),fla as boolean
ar = range(“a1:a100”).Value
mro% = 99
Do While mro> 1
     fla = True
     i% = mro
     For k% = 1 To i
           If ar(k, 1) >ar(k + 1, 1) Then
               fla = False
               tem% = ar(k, 1)
              ar(k, 1) = ar(k + 1, 1)
              ar(k + 1, 1) = tem
              mro = k   ‘记录进行交换的位置，其最后一个值作为下一回for循环的终值
          End If
     Next
     If fla Then mro = 0
Loop
[h1:h100] = ar
End Sub
     还有其它很多很多的排序：归并排序、希尔排序、快速排序等等，大家可以去参考相关资料。所有这些排序（包括前面写到的）都各有优缺点，不见得改进的就一定比未改进的好（主要是数据源情况不同时其表现就不同，特定情况下甚至会使改进成为负担）。
  
     所有的这些方法，都是教科书上的，仅供训练思维使用。其实excel自带的排序就非常非常好，如前面的是排a1:a100只需Range("a1:a100").Sort ([a1])就行，而且速度远比前面写的要快很多（据说有能写出比excel自带的排序更快代码的，但是我不能）
前面说了堆积木的种种规则，但那是程序设计的。Excel中的vba必然要与excel打交道，这就有相应的规则在里面，同时还有他所独有的一些积木块，这些都是学VBA所不容回避的。规则我们要记住，但是那些积木块却太多太多，又都是英语的，要全部记住几乎是不可能的（反正我只记住了很少很少的一部份），那怎么办？没关系，有几种方法：录制宏，到那里面去找；查帮助；网上搜索；收录一些文件，如http://www.excelpx.com/thread-58127-1-4.html就是前人收集在一起的一个较全的集子；等等方式。下面我们就用个实例来看看如何从录制宏中找出我们想要的东西并恰当地运用到我们的程序中去：
实例一：当前excel文件中的sheet1中有形如下图的成绩表，

需要在sheet2中做出如下图所示的成绩条以便打印出来发给学生：

    （当然你也可以将它改成单位工资表打印工资条）此问题用函数、技巧我们是可以完成，但学了VBA，我们当然希望用VBA来做。为此我们还是按贯例先来看手工下是如何做的：
    第一个人：1. A1:J1合并并居中。 2. 将A3：J4设置所有框线。3.输入数据
    第二个人：与第一个人的雷同
    第三个人：与第一个人的雷同
    ……
    这不就是循环吗？这我们是有经验的，为此我们只要将第一个人的完成了，在外层增加个循环，就可将所有的人都做完。那么如何来做这第一个学生的呢？下面我们来慢慢完成：
A1:J1合并居中，在手工下就是选中A1:J1，然后点合并居中按钮，现在我们用录制宏将这一手工过程记录下来：
Sub 宏1()
'
' 宏1 宏
'
'Range("A1:J1").Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With
Selection.Merge
End Sub
    简单的一个合并居中所录制的宏代码就是这么一大堆？对不懂鸟文的人来说，V就这么难呀？怕怕（这里面绝大部份鸟文是他不认识我我更不认识他）。
    其实他实现的不仅仅是合并居中，因为是录制宏，他要将将方方面面的东西都记录下来，而我们所需要的只是合并居中这么一点。那如何从中找出我们所需要的呢？我是这样干的：
将sheet2中的内容全部删除（不是清除内容，而是选中整张表-------点右键------点删除），这样就将整张sheet恢复到初始状态，在A1中输入任意内容，将VBE窗口缩小并移到合适的位置，只要能看到sheet中的A1:J1就可以了。这时单步执行刚录的宏来观察每一行所起的作用，这时可看到Range("A1:J1").Select是选中单元格区域A1:J1，.HorizontalAlignment = xlCenter是水平居中，如果行高有点高的话还可以明显看到.VerticalAlignment = xlCenter是垂直居中，后面的看不出什么变化，直到Selection.Merge时可看到A1:J1合并了。可见，要合并单元格核心的语句就是Selection.Merge，其它的都是此处所不需要的（注意，仅仅是此处合并所不需要的），为了验证这一想法，我们试试将其它语句都注释掉（或干脆删掉）:
Sub 宏1()
Selection.Merge
End Sub
    再执行一下看是不是。错了错了，没合并呢？原来是Range("A1:J1").Select没了，仅有Selection.Merge，而当前只选中了一个单元格，一个单元格怎么合并？那我们就任意选中几个单元格，再执行一下看。怎么样？合并了吧？哈哈，找到了，合并就是他：Merge
    可是还有点不对的地方：要不就有单元格区域. Select，要不就是当前选中有单元格区域，才能Selection.Merge，可见是先选中再合并，能不能再简单点呢？为此，经试验合并a1:j1的代码就成了：
Sub 宏1()
Range(“A1:j1”).Merge
End Sub
那么长一段代码，最后就整出这么三行，简单吧？就这么简单！
可是，没对，还没对！还有居中呢？居中嘛，再加不就完了？仿合并的：
Sub 宏1()
Range(“A1:j1”).Merge
Range(“A1:j1”).HorizontalAlignment = xlCenter   ‘这是水平居中的
Range(“A1:j1”).VerticalAlignment = xlCenter       ‘这是垂直居中的
End Sub
    如果还要其它功能就再加就是了，看你的需要而定嘛，哈哈
    大家去试试通过录制宏，实现整张表格所有内容清除、整张表格内容水平居中和垂直居中、行高25、A1:j1合并、D2:E2合并的功能，我们这里仅给出最终代码：
Sub 宏1()
Cells.clear    ‘整张表格所有内容清除
Cells.HorizontalAlignment = xlCenter    '整张表格所有内容水平居中
Cells.VerticalAlignment = xlCenter        '整张表格所有内容垂直居中
Cells.RowHeight = 25                             '整张表格行高为25
Range(“A1:j1”).Merge                           ‘合并A1:j1
Range(“D2:E2”).Merge                          ‘合并D2:E2
End Sub
    注意：录的宏中其它东东都不是无用的，有兴趣的可以选中鸟文后按f1从帮助中看他们是做何用的。对于所有的这些东西，你能够把他们都记住、能独立写出来固然非常好，但是如果象我一样实在记不住，那也没什么大不了的，只要大至有个印象，到要用的时候任意录制个宏，从宏中能把他们选出来就行了（我就是这样干的，嘿嘿）。
    下面我们来给A3:J4设置边框：同样录个宏，得到的代码如下：
Sub 宏2()
'
' 宏2 宏
'
'
Range("A3:J4").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
End Sub
    越整越多了，这么长，真晕！别急，有前面的经验，慢慢来：还是先将A3:J4的所有东西都删了，然后一边单步执行代码，一边仔细观察A3:J4的变化。可以看到：
Range("A3:J4").Select与前面的相同，就是选择该区域Selection.Borders(xlDiagonalDown).LineStyle = xlNone 没什么明显变化（查帮助方知是去除斜线），下一句Selection.Borders(xlDiagonalUp).LineStyle = xlNone也一样（斜线有两个方向嘛）后面的六个With语句分别是加左、上、下、右、中间的竖、中间的橫边框，而且加框线就.LineStyle = xlContinuous，另几个是线型颜色什么的。对这个进行精减要稍动点脑筋，在结合帮助的情况下我最终将他整成了（只有一句，下面把他与前面的内容合在一起了）：
Sub 宏1()
Cells.clear       ‘整张表格所有内容清除
Cells.HorizontalAlignment = xlCenter     '整张表格所有内容水平居中
Cells.VerticalAlignment = xlCenter         '整张表格所有内容垂直居中
Cells.RowHeight = 25                             '整张表格行高为25
Range(“A1:j1”).Merge                           ‘合并A1:j1
Range(“D2:E2”).Merge                         ‘合并D2:E2
Range("A3:J4").Borders.LineStyle = xlContinuous          ‘设置单元格区域A3:J4的边框为实线
End Sub
    下面我们来填数据：
    要填数据，得先把数从sheet1中取出来。虽然可以取一个填一个，但这样速度很慢，为速度计我们采取两个措施：
    1、先将sheet1中的数据取出来放到一数组中。要用数时就从这个数组中来取
    2、学生数据不是直接写入单元格，而是先写入一目的数组中，然后再一次性写入单元格区域
    为此我们先定义一个动态数组（dim arr1()，必须是动态数组，要是固定数组的话就不能一次性将数据全放进去了），然后用数组名=单元格区域.value的形式一次性将数据放进数组中。
Sub 宏1()
Dim arr1(), arr2(1 To 4, 1 To 10)
Dim i1%,  i2%,   l&
arr1 = Sheets("sheet1").UsedRange.Value    '将sheet1的所有数据存入数组arr1，这样取来的第一行表头也在里面了
Sheets("sheet2").Select     ‘选中sheet2
Cells.Clear                         '清除当前表格的所有内容（包括格式）
Cells.HorizontalAlignment = xlCenter    '整张表格所有内容水平居中  
Cells.VerticalAlignment = xlCenter       '整张表格所有内容垂直居中
Cells.RowHeight = 25                           '整张表格行高为25

'以下生成目的数组。暂时还没有学生信息

arr2(1, 1) = "*学校*学年度下期成绩通知单"
arr2(2, 1) = "姓名"
arr2(2, 3) = "学号"
arr2(2, 8) = "班级"
For i1 = 1 To 10      ‘这个循环用于写科目名称到目的数组的第三行中去
      arr2(3, i1) = arr1(1, i1 + 3)        '为什么要i1+3呢？
Next


‘以下填入第一个学生的信息到目的数组中去：

arr2(2, 2) = arr1(2, 3)      ‘写姓名
arr2(2, 4) = arr1(2, 2)      ‘写学号
arr2(2, 9) = arr1(2, 1)      ‘写班级
For i1 = 1 To 10               ‘这个循环用于写各科成绩到目的数组的第三行中去
      arr2(4, i1) = arr1(2, i1 + 3)       '为什么要i1+3呢？
Next
Range("A1:j4") = arr2       '将数据写入表格，这样第一个学生的信息就填好了


'下面来设置格式
Range("A1:j1").Merge        '这是合并
Range("d2:e2").Merge      '这是合并
Range("A3:J4").Borders.LineStyle = xlContinuous      '这是设置边框
End Sub
        这样第一个学生的信息就填完整了。单步执行一下，看情况是否如我们所料。
        如果是只到这里，那么V就太麻烦了，小小的一个事情整得这么复杂，还不如手工来得爽。但是我们的目的不仅仅是做出第一个学生的，而是要将很多很多的学生都做出来。有了第一个学生的，其他的就变得非常简单：只需我们在外加个循环就成了。现在我们来看如何加循环：
        循环应该包括两层意思：循环取数和循环写数。
        循环取数，我们已经将数据取到数组arr1中了，在数组arr1中，从第二行起每个学生占一行，固只须从第二行起一行一行地读下去就可以了。可见这是个初值为2、终值为数组arr1最大下标、步长为1的循环。
        循环写数，要稍麻烦点，由示例要求得知，在sheet2中是从第一行起，第一个学生占第1至4行，然后空1行；第二个学生占第6至9行，然后空1行……也就是说从第一个学生起每个学生的起始行依次是1、6、11……看出规律了吗？这是个初值为1、步长为5、循环次数与取数相同，是不？
        那么如何将这两个整合在一起呢？这里直接给出结果，大家自己体会吧：
Sub 宏1()
Dim arr1(), arr2(1 To 4, 1 To 10)
Dim str1$, i1%, i2%, l&
arr1 = Sheets("sheet1").UsedRange.Value
Sheets("sheet2").Select
Cells.Clear    '清除当前表格的所有内容（包括格式）
Cells.HorizontalAlignment = xlCenter    '整张表格所有内容水平居中
Cells.VerticalAlignment = xlCenter    '整张表格所有内容垂直居中
Cells.RowHeight = 25    '整张表格行高为25

'以下生成目的数组。暂时还没有学生信息

arr2(1, 1) = "*学校*学年度下期成绩通知单"
arr2(2, 1) = "姓名"
arr2(2, 3) = "学号"
arr2(2, 8) = "班级"
For i1 = 1 To 10
    arr2(3, i1) = arr1(1, i1 + 3)
Next

l = 1     ‘初值为1，因为第一个学生是从第一行开始填
For i1 = 2 To UBound(arr1)      '循环初值从2开始，循环到arr1的最大下标，步长为1.可是这个循环为什么要加在此处呢？能否前后移动呢？
    arr2(2, 2) = arr1(i1, 3)
    arr2(2, 4) = arr1(i1, 2)
    arr2(2, 9) = arr1(i1, 1)
    For i2 = 1 To 10
        arr2(4, i2) = arr1(i1, i2 + 3)
    Next
    Range("A" & l & ":j" & l + 3) = arr2    '将数据写入表格，这样第一个学生的信息就填好了，下面来设置格式
    Range("A" & l & ":j" & l).Merge    '这是合并
    Range("d" & l + 1 & ":e" & l + 1).Merge    '这是合并
    Range("A" & l + 2 & ":j" & l + 3).Borders.LineStyle = xlContinuous     '这是设置边框
    ‘上面为什么有寻么多的&和+呢？结果是什么？可以在上面加一行tmp="A" & l + 2 & ":j" & l + 3并单执行，就可看到"A" & l + 2 & ":j" & l + 3的作用是啥子了，其它雷同

    l = l + 5    ‘下一个学生开始的位置
Next
End Sub
    这样这个工程就差不多了。收拾下思绪，对这个问题我们再提点东东：
    为速度计，其一我们还必须在程序开始位置再加一句：Application.ScreenUpdating = False，作用是关闭屏幕更新，从而达到提速的目的；其二，这个代码数组用得还不够彻底，向表中写数据时，一个学生写一次，在数据量大的情况下速度肯定快不起来，还可以考虑将所有学生的数据全写到一个数组中后再一次性写进表格；其三，每个学生都进行两次合并单元格、一次设置边框，同样可以优化思路，以达到提速的目的。
    说这么几点，实际就是提速提速再提速。
    不过，这不是这部份内容的主题，这部份内容的主题是录制宏，在帮助的帮助下运用一些手段从录的宏中准确地找出我们所需要的东西并恰当地运用到我们的代码中去，因此只要这个目的达到了就成了。

我们再来看看坛子中经常而且反复出现的一个问题：删除空行
    对于这个问题，用技巧等等方式非常好解决，这里我们不去谈他，现在仅试图用VBA来解决看看
    问题描述：如下图所示，当前表格中的B2至B25001区域中，有的地方是由函数产生的空（即假空），有的地方确实是没内容的真空（f2和f3两个单元格公式结果可看出这个情况），如何用VBA将B列的这些真空和假空所在的行整行删除呢？

    先复习下录制宏：删除一行、连续的几行、不连续的几行的宏代码，经修改后的结果是：
    删除单行：Rows(3).Delete 或 Range("3:3").Delete  ’将第三行删除
    删除连续几行：Rows("4:10").Delete或Range("4:10").Delete  ’ 将第四至第十行删除
    删除不连续几行：Range("8:8,12:15,23:33").Delete
还有以下形式：
Range("B4").EntireRow.Delete’将B4所在的行删除
Range("B4:b10").EntireRow.Delete’将B4至B10所在的行删除
Range("B4,b6:b10").EntireRow.Delete’将B4和b6至b10所在的行删除
    有了这些积木块后，再加上以前的循环、判断等等积木块，下面我们来实现删除空行的目的。
    还是先来看看我们人工做这个活路时是如何来做的（贯穿始终的思想：编代码其实就是将我们的想法翻译成对应的VBA代码）：
    对B列单元格，从上往下一个一个地来看，只要他是为空，就删除该行，直到所有的都完成为止。
    因此，很容易就得出以下代码（为了方便我们暂时只做到第10行）：
Sub delblankrow()
For i% = 2 To 10
    If Cells(i, 2) = "" Then Rows(i).Delete
Next
End Sub
    这个代码应该是非常容易看明白的，也可将Cells(i, 2) = ""改成len(cells(I,2))<1。真假空都能删除。
    可是，还是有点没对呢？当有连续空单元格时，运行一次是删除不完的，为什么会这样？探究一下原因（我们把B列内容都清除了，并在代码中增加一行）：
Sub delblankrow()
For i% = 2 To 10
    If Cells(i, 2) = "" Then
       Rows(i).select  ‘增加这么一行，先选中这行后再删除。
       Rows(i).Delete
    endif
Next
End Sub
    增加了Rows(i).select这么一行，先选中这行后再删除，很清楚地看到：i=4时，判断Cells(4, 2)为空，选中了这行然后删除了，i增加1，成了5，就去判断Cells(5, 2)是否为空去了，这里产生了遗漏！因为Cells(4, 2)为空在删除第四行时，第五行自然上移成了第四行（后面的行都依次上移了一行），下一个判断Cells(5, 2)是否为空时这个Cells(5, 2)实际上是以前的第六行，以前的第五行（现在的第四行）就没有去判断了。这就是这段代码出错的原因所在！
    明白了产生错误的原因，那么如何来改呢？先给出个简单的、间接的改法，倒循环：
    前面的错误是因为删除一行后下面的行上移而造成漏判，因此我们可以改成从最后一行开始往上进行判断删除（为什么这样就没遗漏了呢？）：
Sub delblankrow2()
For i% = 10 To 2 step -1
    If Cells(i, 2) = "" Then
        Rows(i).select‘增加这么一行，先选中这行后再删除。实际代码中去除它
        Rows(i).Delete
    endif
Next
End Sub
    那么只能用倒循环吗？再来看看：第一段代码的错误是在于某行删除了后，下面的行依次上移，代码没有考虑到上移这一情况。我们现在将这一情况考虑进去：删除某行、下面的行自动依次上移后再对这行进行判断：
Sub delblankrow3()
r%=2
For i% = 2 To 10
    If Cells(r, 2) = "" Then
        Rows(r).Delete
    else
        r=r+1
    endif
Next
End Sub
    这样，多用一个变量来表示当前需要判断的行就达到目的了。对于以下代码，请大家自己来理解理解其思路：
Sub delblankrow4()
r% =10
i%=2
Do While i <=r
    If Cells(i, 2) = "" Then
        Rows(i).Delete
        r=r-1
    Else
        i = i + 1
    End If
Loop
End Sub
    后面这两个虽然都可以达到目的，但都不如delblankrow2简洁明了，看来还是用delblankrow2这样的倒循环要好些。delblankrow2完整的代码应该如下：
Sub delblankrow5()
Application.ScreenUpdating = False '关闭屏幕刷新
For i% =10 To 2 Step -1
    If Cells(i, 2) = "" Then Rows(i).Delete
Next
End Sub
    说到这里，看似这个问题就结束了。
    可是，这只做到了2至10行，要是改到如开头时讲的到25001行或者更多行，用这个代码那慢得要死！不信你试试。慢的原因是什么？慢就慢在两个方面：读单元格的次数太多（每次判断都要读一次单元格）、删除的次数太多（每有一个空就删除一次）。要想提速，必须从这两方面入手！对于读单元格的次数太多可以如以前所用的办法：定义一个数组，将需要判断的B列数据事先一次性读入数组，循环判断时只读取数组而不是去读单元格，从而达到提速的目的。而对于删除的次数太多的问题，就要用到点技巧了，我们可以这样来想：在一开始时回顾了录制宏，并得到了删除一行、连续的几行、不连续的几行的宏代码，如删不连续几行的Range("8:8,12:15,23:33").Delete，要是我们能将需要删除的行先找出来，然后按规则构造成形如"8:8,12:15,23:33"的字符串存入变量delstr中，然后再用Range(delstr).Delete，行不？要是可行的话，多行不是只删一次就可以了吗？马上试验，将delblankrow2按这个思路来改看行不：
Sub delblankrow6()
Dim arr1(), delstr$
arr1 = [b1:b10].Value'将B列数据读入数组
For i% = UBound(arr1) To LBound(arr1) + 1 Step -1'从数组的最大下标循环到最小下标+1，步长为-1
    If arr1(i, 1) = "" Then delstr = delstr & "," & i & ":" & i'构造字串
Next
If Len(delstr) > 1 Then'delstr有没有内容
    delstr = Right(delstr, Len(delstr) - 1)'构造的字串delstr的第一个字符为,得去掉
    Range(delstr).Delete'删除delstr所指定的行
End If
End Sub
    执行一下，是可行的。这样，删除多行只执行了一次delete，达到了提速的目的。
    我们把它扩展到25001行，怎么错了呢？出现了错误提示：

    为什么少的时候可行而多了就不行了呢？而多少恰巧是delstr的内容的多少的问题。为此我们可以将delstr分成几段来分次删除，以下实现这一思想：
Sub delblankrow7()
Dim arr1(), delstr$
Application.ScreenUpdating = False '关闭屏幕刷新
arr1 = [b1:b25001].Value'将B列数据读入数组
For i% = UBound(arr1) To LBound(arr1) + 1 Step -1'从数组的最大下标循环到最小下标+1，步长为-1
    If arr1(i, 1) = "" Then
        delstr = delstr & "," & i & ":" & i'构造字串
        If Len(delstr) > 240 Then‘字串达到一定长度执行删除，经试验240是个合适的值
            delstr = Right(delstr, Len(delstr) - 1)'构造的字串delstr的第一个字符为,得去掉
            Range(delstr).Delete'删除delstr所指定的行
            delstr = ""'将字串delstr清空
        End If
    End If
Next
If Len(delstr) > 1 Then'delstr还有没有内容
    delstr = Right(delstr, Len(delstr) - 1)'构造的字串delstr的第一个字符为,得去掉
    Range(delstr).Delete'删除delstr所指定的行
End If
End Sub
    至此，大部完成了，基本可以接受。
    还有一点：连续空行！目前的代码对于如本例中的连续空行4、5、6、7其生成的字串是”4:4,5:5,6:6,7:7”对不？而我们前面的录制的宏Range("8:8,12:15,23:33").Delete中，这样的连续空行表示成”4:7”就成了，如何才能达到这个目的呢？需要我们增加个连续空行的，那就再来改嘛：
Sub delblankrow8()
Dim arr1(), delstr$
Application.ScreenUpdating = False '关闭屏幕刷新
arr1 = [b1:b25001].Value'将B列数据读入数组
For i% = UBound(arr1) To LBound(arr1) + 1 Step -1'从数组的最大下标循环到最小下标+1，步长为-1
    If arr1(i, 1) = "" Then
        tmpi = i - 1
        Do While tmpi > 1
            If arr1(tmpi, 1) <> "" Then
                delstr = delstr & "," & i & ":" & tmpi + 1 '构造字串
                i = tmpi
                tmpi = 1
            Else
                tmpi = tmpi - 1
            End If
        Loop
        If Len(delstr) > 240 Then
            delstr = Right(delstr, Len(delstr) - 1)  '构造的字串delstr的第一个字符为,得去掉
            Range(delstr).Delete  '删除delstr所指定的行
            delstr = ""   '将字串delstr清空
        End If
    End If
Next
If Len(delstr) > 1 Then  'delstr有没有内容
    delstr = Right(delstr, Len(delstr) - 1)  '构造的字串delstr的第一个字符为,得去掉
    Range(delstr).Delete  '删除delstr所指定的行
End If
End Sub
    这样一来，相对来说较为满意了。
    但同时这个代码给出了一个很不好的范例：for循环中对循环变量进行了更改！
    可是还是有点不满意：示例中的空，有的是真空有的是假空，对于真空而言，e提供了个定位空值的功能，为什么我们不先定位真空并删除真空所在的行，再用上面的代码来删除假空所在的行呢？这里我们仅给出定位B列空值并删除其所在行的录制宏经修改后的代码：
Columns("B:B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
要实现上述思想大家自行去组合吧。
--------------------------------------------------------------------------------------------------------------
    上面的代码全部都是按循环判断是否为空来决定是否删除这一思路来做的。其实我们还可以换换思路：在循环判断后，不删除他，而是在右边增加个辅助列，来记录是否为空，完成后利用E自带的排序，将为空的（不管真空还是假空）都排在一起，然后一次性删除就行了。为此我们将Sub delblankrow6()改成这一思想：
Sub delblankrow9()
Dim arr1()
arr1 = [b1:b25001].Value   '将B列数据读入数组
For i% = 2 To UBound(arr1)   '从数组的最大下标循环到最小下标+1，步长为-1
    If arr1(i, 1) <> "" Then
        arr1(i, 1) = 1  '这是随意赋的值
    Else   '对于此例，else和arr1(i,1)=""都可以不要
        arr1(i, 1) = ""
    End If
Next
[d1].Resize(i - 1) = arr1'写入一个空列，为辅助列
[a2].Resize(i - 2, 4).Sort ([d1])'按辅助列排序，空值就都被排到后面去了
Range("25001:" & 1 + Cells(i, 4).End(xlUp).Row).Delete'删除后面的空值所在的行
Range("D:D").Clear'清空辅助列
End Sub
    还有没有其它方法呢？如筛选等等？我想，肯定有，大家自己去试吧。
    “思路决定出路”，确实不假，只要思路正确，把他翻译成VBA代码就成了，堆积木嘛，啷个堆都成，哈哈……

终于登载完，这是我看到的VBA入门的最好资料，推荐给爱好VBA的土友，谢谢大家！

学习下

这么好的东西 大家要关注下哦

顶起来顶起来顶起来顶起来

我想入门 学习

不错，共同学习一下。

学习学习啦