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