Excel-VBA练习题目代码留存

目录：

一、将工资表设置成工资条（用宏的方式）

二、将各工作表的数据汇总到“汇总表”，各个工作表的结构相同

三、将各个工作表分别保存成单独的工作簿

四、性别为男称呼为先生，否则为女士，姓名为空的删除整行，每个表处理完后分别存为新的工作簿文件

 五、用户输入列数，根据列数内容拆分数据，相同内容的存为一个工作表，并将处理完的工作表分别存为工作簿

 六、打开/关闭 工作簿时隐藏表相关问题

七、利用VBA计算日期

八、将拆分报表的代码改为通用代码且设置为加载宏

九、多个工作簿的内容（单张表）合并到一张表中

十、商品数据记录系统

一、将工资表设置成工资条（用宏的方式）

Sub 工资条()
    Columns("A:L").Select
    Columns("A:L").EntireColumn.AutoFit
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A1").Select
    Dim i As Integer
    For i = 1 To 10
    ActiveCell.Rows("1:2").EntireRow.Select
    Selection.Copy
    ActiveCell.Offset(3, 0).Rows("1:1").EntireRow.Select
    Selection.Insert Shift:=xlDown
    Application.CutCopyMode = False
    ActiveCell.Offset(1, 0).Range("A1:L2").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
    ActiveCell.Offset(-1, 0).Range("A1").Select
    Next
    Range("A2:L3").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
    Range("A1").Select
End Sub

二、将各工作表的数据汇总到“汇总表”，各个工作表的结构相同

Sub homework()
Dim i As Integer
For i = 2 To Sheets.Count
Sheet1.Range("B" & i + 6) = Sheets(i).Range("E3")
Sheet1.Range("C" & i + 6) = Sheets(i).Range("E4")
Sheet1.Range("D" & i + 6) = Sheets(i).Range("E30")
Next
End Sub

三、将各个工作表分别保存成单独的工作簿

Sub homework()
Dim sht As Worksheet
For Each sht In Sheets
    sht.Copy
    ActiveWorkbook.SaveAs Filename:=("E:Excel_date" & sht.Name & ".xlsx")
    ActiveWorkbook.Close
Next
End Sub

结果：

 四、性别为男称呼为先生，否则为女士，姓名为空的删除整行，每个表处理完后分别存为新的工作簿文件

Sub homework()
Dim sht As Worksheet
Dim i As Integer
For Each sht In Sheets
    sht.Select
        For i = 100 To 2 Step -1
            '判断称呼
            If Range("E" & i) = "男" Then
                Range("F" & i) = "先生"
            Else
                Range("F" & i) = "女士"
            End If
            '填写专业代号
            Select Case Range("B" & i)
            Case Is = "理工": Range("C" & i) = "LG"
            Case Is = "文科": Range("C" & i) = "WK"
            Case Is = "财经": Range("C" & i) = "CJ"
            End Select
            '删除空行
            If Range("D" & i) = "" Then
            Range("D" & i).EntireRow.Delete
            End If
        Next
        '将工作表另存为工作簿
        sht.Copy
        ActiveWorkbook.SaveAs Filename:=("E:Excel_date" & sht.Name & ".xlsx")
        ActiveWorkbook.Close
Next
End Sub

 五、用户输入列数，根据列数内容拆分数据，相同内容的存为一个工作表，并将处理完的工作表分别存为工作簿

Sub 拆分报表()

Dim i, k, j, v As Integer
Dim sht, d_sht As Worksheet

v = InputBox("你想根据第几列分呢？")

'删除工作簿中多余工作表
For Each d_sht In Sheets
If d_sht.Name <> "数据" Then
    d_sht.Delete
End If
Next

'创建工作表
For i = 2 To Sheet1.Cells(65536, v).End(xlUp).Row
    k = 0
    For Each sht In Sheets
    If Sheet1.Cells(i, v).Value = sht.Name Then
        k = 1
    End If
    Next
    If k = 0 Then
    Sheets.Add after:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = Sheet1.Cells(i, v).Value
    End If
Next

'筛选数据并复制到对应工作表
For j = 2 To Sheets.Count
    Sheet1.Cells.AutoFilter Field:=v, Criteria1:=Sheets(j).Name
    Sheet1.Cells.Copy Sheets(j).Range("A1")
Next
Sheet1.Cells.AutoFilter
Sheet1.Select
MsgBox "已处理完毕，请说牛逼，谢谢！"
End Sub

Sub 另存为文件()
Dim file As String
Dim sht As Worksheet
file = InputBox("请输入保存工作簿完整路径")
For Each sht In Sheets
    sht.Copy
    ActiveWorkbook.SaveAs Filename:=(file & "" & sht.Name & ".xlsx")
    ActiveWorkbook.Close
Next


End Sub

结果：

 六、打开工作簿隐藏除 登录 表外的表并前输入密码，如果密码为123，则显示张三1、张三2、张三3三张工作表，如果密码为456，则显示李四1、李四2、李四3这三张工作表，关闭工作簿前隐藏除 登录 表外的所有表

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim sht As Worksheet
For Each sht In Sheets
If sht.Name <> "登录" Then
    sht.Visible = xlSheetHidden
    End If
Next
End Sub

Private Sub Workbook_Open()
'隐藏工作表
Dim sht As Worksheet
For Each sht In Sheets
If sht.Name <> "登录" Then
    sht.Visible = xlSheetHidden
    End If
Next
'输入密码
Dim V, i As Integer
V = InputBox("请输入密码：")
For i = 1 To 3
    If V = 123 Then
            Sheets("登录").Select
            Sheets("张三" & i).Visible = True
    ElseIf V = 456 Then
            Sheets("登录").Select
            Sheets("李四" & i).Visible = True
    Else
        MsgBox "密码输入错误"
        ThisWorkbook.Close
    End If
Next
End Sub

 七、利用VBA 计算日期

 

Sub try()
'第一题完整写法
Dim i As Integer
For i = 2 To Sheet1.Range("A65535").End(xlUp).Row
Sheet1.Range("B" & i) = VBA.DateTime.DateSerial(VBA.Strings.Left(Sheet1.Range("A" & i), 4), VBA.Strings.Mid(Sheet1.Range("A" & i), 5, 2), VBA.Strings.Right(Sheet1.Range("A" & i), 2))
Next
End Sub

Sub try_1()
'第一题简便写法
Dim i As Integer
For i = 2 To Sheet1.Range("A65535").End(xlUp).Row
Sheet1.Range("B" & i) = DateSerial(Left(Sheet1.Range("A" & i), 4), Mid(Sheet1.Range("A" & i), 5, 2), Right(Sheet1.Range("A" & i), 2))
Next
End Sub


Sub try_2()
'第二题简便写法
Dim i As Integer
For i = 2 To Sheet1.Range("A65535").End(xlUp).Row
Sheet2.Range("B" & i) = DateSerial(Mid(Sheet2.Range("A" & i), 7, 4), Mid(Sheet2.Range("A" & i), 11, 2), Mid(Sheet2.Range("A" & i), 13, 2))
Next
End Sub

八、将拆分报表的代码改为通用代码且设置为加载宏

Sub 拆分报表()
Dim sheet_name As String
Dim i, k, j, v As Integer
Dim sht, d_sht As Worksheet
sheet_name = ActiveSheet.Name
v = InputBox("你想根据第几列分呢？")

'删除工作簿中多余工作表
For Each d_sht In Sheets
If d_sht.Name <> Sheets(sheet_name).Name Then
    d_sht.Delete
End If
Next

'创建工作表
For i = 2 To Sheets(sheet_name).Cells(65536, v).End(xlUp).Row
    k = 0
    For Each sht In Sheets
    If Sheets(sheet_name).Cells(i, v).Value = sht.Name Then
        k = 1
    End If
    Next
    If k = 0 Then
    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = Sheets(sheet_name).Cells(i, v).Value
    End If
Next

'筛选数据并复制到对应工作表
For j = 1 To Sheets.Count
    If Sheets(j).Name <> sheet_name Then
        Sheets(sheet_name).Cells.AutoFilter Field:=v, Criteria1:=Sheets(j).Name
        Sheets(sheet_name).Cells.Copy Sheets(j).Range("A1")
    End If
Next
Sheets(sheet_name).Cells.AutoFilter
Sheets(sheet_name).Select
MsgBox "已处理完毕，请说牛逼，谢谢！"
End Sub

 九、多个工作簿的内容（单张表）合并到一张表中

Sub try()
Dim i, v As Integer
Dim str As String
Dim sht As Worksheet
str = Dir("E:Excel_date*.*")
k = ThisWorkbook.Sheets(1).Range("A65536").End(xlUp).Row
For i = 1 To 100
    Set wb = Workbooks.Open("E:Excel_date" & str)
    m = wb.Sheets(1).Range("A65535").End(xlUp).Row
    wb.Sheets(1).Range("A2:G" & m).Copy ThisWorkbook.Sheets(1).Range("A" & k + 1)
    k = ThisWorkbook.Sheets(1).Range("A65536").End(xlUp).Row
    ThisWorkbook.Sheets(1).Range("H" & ThisWorkbook.Sheets(1).Range("H65535").End(xlUp).Row + 1 & ":" & "H" & k) = Split(wb.Name, ".")(0)
    wb.Close
    str = Dir
    If str = "" Then
        Exit For
    End If
Next
End Sub

十、商品数据记录系统

Dim arr()
Dim ID As String

Private Sub CommandButton1_Click()
On Error Resume Next
If Me.ListBox3.Value <> "" And Me.TextBox1.Value > 0 And Me.TextBox1.Value <> "" And IsNumeric(Me.TextBox1.Value) = True Then
    With Me.ListBox4
        .AddItem
        .List(.ListCount - 1, 0) = ID
        .List(.ListCount - 1, 1) = Me.ListBox1.Value
        .List(.ListCount - 1, 2) = Me.ListBox2.Value
        .List(.ListCount - 1, 3) = Me.ListBox3.Value
        .List(.ListCount - 1, 4) = Me.TextBox1.Value
        .List(.ListCount - 1, 5) = Me.TextBox1.Value * Me.Label2.Caption
    End With
Me.Label5.Caption = Me.Label5.Caption + Me.TextBox1.Value * Me.Label2.Caption
Else: MsgBox "请正确选择商品"
End If
End Sub

Private Sub CommandButton2_Click()
For i = 1 To Me.ListBox4.ListCount - 1
 If Me.ListBox4.Selected(i) = True Then
    Me.Label5.Caption = Me.Label5.Caption - Me.ListBox4.List(i, 5)
    Me.ListBox4.RemoveItem i
End If
Next

End Sub

Private Sub CommandButton3_Click()
If Me.ListBox4.ListCount >= 2 Then
    Dim i, K As Integer
    Ddid = "D" & Format(VBA.Now, "yyyymmddhhmmss")
    For i = 1 To Me.ListBox4.ListCount - 1
        K = Sheet2.Range("A65535").End(xlUp).Row + 1
        Sheet2.Range("A" & K) = Ddid
        Sheet2.Range("B" & K) = Date
        Sheet2.Range("C" & K) = Me.ListBox4.List(i, 0)
        Sheet2.Range("D" & K) = Me.ListBox4.List(i, 4)
        Sheet2.Range("E" & K) = Me.ListBox4.List(i, 5)
    Next
    MsgBox "记录添加成功"
Else: MsgBox "未选择商品"
End If
Result = MsgBox("是否关闭当前系统窗口？", 4 + 32)
If Result = 6 Then
    Unload Me
    Sheet2.Select
End If
End Sub


Private Sub CommandButton4_Click()
Result = MsgBox("是否清空全部内容？", 4 + 32)
If Result = 6 Then
With Me
    .ListBox2.Clear
    .ListBox3.Clear
    .Label2.Caption = ""
    .TextBox1.Value = ""
    .ListBox4.Clear
    .Label5.Caption = ""
End With
End If
End Sub

Private Sub ListBox1_Click()
Dim dic
Set dic = CreateObject("Scripting.Dictionary")
Me.ListBox2.Clear
Me.ListBox3.Clear
Me.Label2.Caption = ""
For i = LBound(arr) To UBound(arr)
    If arr(i, 2) = Me.ListBox1.Value Then
    dic(arr(i, 3)) = 1
    End If
Next
Me.ListBox2.List = dic.keys
End Sub

Private Sub ListBox2_Click()
Dim dic
Set dic = CreateObject("Scripting.Dictionary")
Me.ListBox3.Clear
For i = LBound(arr) To UBound(arr)
    If arr(i, 2) = Me.ListBox1.Value And arr(i, 3) = Me.ListBox2.Value Then
    dic(arr(i, 4)) = 1
    End If
Next
Me.ListBox3.List = dic.keys
End Sub

Private Sub ListBox3_Click()
Dim dic
Set dic = CreateObject("Scripting.Dictionary")
For i = LBound(arr) To UBound(arr)
    If arr(i, 2) = Me.ListBox1.Value And arr(i, 3) = Me.ListBox2.Value And arr(i, 4) = Me.ListBox3.Value Then
        Me.Label2.Caption = arr(i, 5)
        ID = arr(i, 1)
    End If
Next
End Sub

Private Sub UserForm_Activate()
Dim dic
Set dic = CreateObject("Scripting.Dictionary")
arr = Sheet1.Range("A2:E" & Sheet1.Range("A65535").End(xlUp).Row)
For i = LBound(arr) To UBound(arr)
    dic(arr(i, 2)) = 1
Next
Me.ListBox1.List = dic.keys
With Me.ListBox4
    .AddItem
    .List(0, 0) = "产品编号"
    .List(0, 1) = "类别"
    .List(0, 2) = "品名"
    .List(0, 3) = "规格"
    .List(0, 4) = "数量"
    .List(0, 5) = "合计"
End With
End Sub