[开发|VBA] VBA参考代码模板

参考文献

1. WPS Excel通过添加宏实现多张表格合并

用例

1. WPS Excel通过添加宏实现多张表格合并

Sub 合并当前目录下所有工作簿的全部工作表()
Dim MyPath, MyName, AWbName
Dim Wb As workbook, WbN As String
Dim G As Long
Dim Num As Long
Dim BOX As String
Application.ScreenUpdating = False
MyPath = ActiveWorkbook.Path
MyName = Dir(MyPath & "\" & "*.xls")
AWbName = ActiveWorkbook.Name
Num = 0
Do While MyName <> ""
If MyName <> AWbName Then
Set Wb = Workbooks.Open(MyPath & "\" & MyName)
Num = Num + 1
With Workbooks(1).ActiveSheet
.Cells(.Range("B65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)
For G = 1 To Sheets.Count
Wb.Sheets(G).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)
Next
WbN = WbN & Chr(13) & Wb.Name
Wb.Close False
End With
End If
MyName = Dir
Loop
Range("B1").Select
Application.ScreenUpdating = True
MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub

2. 取出同名学生信息

Sub 导出同名学生()
'
' 导出同名学生 Macro
'
    Dim SH As String
    SH = "Sheet4"
    Dim SH1 As String
    SH1 = "Sheet1"   
    Sheets(SH).[a1] = "账号"
    Sheets(SH).[b1] = "姓名"
    Sheets(SH).[c1] = "卡号"
    Sheets(SH).[d1] = "卡片类型"
    Sheets(SH).[e1] = "身份"
    Sheets(SH).[f1] = "卡户押金"
    Sheets(SH).[g1] = "钱包号"
    Sheets(SH).[h1] = "卡余额"
    Sheets(SH).[i1] = "库余额"
    Sheets(SH).[j1] = "未圈存金额"
    Sheets(SH).[k1] = "未圈存笔数"

    '判断学生名单的行数
    a = Sheets(SH1).[a1].CurrentRegion.Rows.Count   
    For I = 2 To a    
    k = Sheets(SH).[a1].CurrentRegion.Rows.Count + 1    
    '使用CountIf()函数对每个学生名字进行判断，如果CountIf()值大于1，则将其复制到Sheet2。   
    If Application.WorksheetFunction.CountIf([b1:b65530], Cells(I, 2)) > 1 Then
        Sheets(SH).Cells(k, 1) = Sheets(SH1).Cells(I, 1)
        Sheets(SH).Cells(k, 2) = Sheets(SH1).Cells(I, 2)
        Sheets(SH).Cells(k, 3) = Sheets(SH1).Cells(I, 3)
        Sheets(SH).Cells(k, 4) = Sheets(SH1).Cells(I, 4)
        Sheets(SH).Cells(k, 5) = Sheets(SH1).Cells(I, 5)
        Sheets(SH).Cells(k, 6) = Sheets(SH1).Cells(I, 6)
        Sheets(SH).Cells(k, 7) = Sheets(SH1).Cells(I, 7)
        Sheets(SH).Cells(k, 8) = Sheets(SH1).Cells(I, 8)
        Sheets(SH).Cells(k, 9) = Sheets(SH1).Cells(I, 9)
        Sheets(SH).Cells(k, 10) = Sheets(SH1).Cells(I, 10)
        Sheets(SH).Cells(k, 11) = Sheets(SH1).Cells(I, 11)
        Sheets(SH).Cells(k, 12) = Sheets(SH1).Cells(I, 12)
    End If
    Next
     Sheets(SH).[a1].CurrentRegion.Sort Key1:=Sheets(SH).[b1], Order1:=xlAscending, Header:=xlGuess
    '对复制到Sheet2的内容以“姓名”作为关键字排序，从而实现同名同姓学生的姓名排在一起，以方便查阅。
    If Sheets(SH).[a2] = "" Then
        MsgBox ("无同名同姓学生！~")
    End If
    '如果没有同名同姓的学生，则跳出报告信息窗口。
    Sheets(SH).Select  
End Sub