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