VBA练习-打开文件，添加选中项，生成新表

Posted 2020-08-11 lunawzh

学习VBA,正好给财务制作一个小工具：

 

Sub 打开人员信息表()
    Dim wb As Workbook, c As Integer
    Set wb = Workbooks.Open("C:\Users\wzn\Documents\工作簿2.xlsx", 0, True)
    c = wb.Worksheets.Count
    If c < 3 Then wb.Worksheets.Add after:=Worksheets(Worksheets.Count)
    wb.Worksheets(1).Select
    
End Sub


Sub 添加选中人员()
    Dim fw As Worksheet, lw As Worksheet, fr As Integer, lr As Integer, rg As Range
    Set fw = ActiveSheet
    Set lw = Worksheets(Worksheets.Count)
    For Each rg In Selection
        fr = rg.Row
        If Range("a" & fr) = "" Or Range("b" & fr) = "" Then
            MsgBox "选中项不能是空值，请确认选中项后重试"
            Exit Sub
        End If
        lr = lw.Range("a65536").End(xlUp).Row + 1
        lw.Range("a" & lr) = Range("a" & fr)
        lw.Range("b" & lr) = Range("b" & fr)
    Next
    If lw.Range("a1") <> "姓名" Then
        lw.Range("a1") = "姓名"
        lw.Range("b1") = "卡号"
        lw.Range("c1") = "金额"
        
        With lw.Range("a1,b1,c1").Font
            .Name = "宋体"
            .Size = 12
            .Bold = True
        End With
    End If
    With lw.Range("a1").CurrentRegion
        .Borders.ColorIndex = 1
        .Columns.AutoFit
        .HorizontalAlignment = xlCenter
    End With
End Sub

Sub 导出添加人员()
    Dim lw As Worksheet, curBook As Workbook
    Set curBook = ActiveWorkbook
    Set lw = Worksheets(Worksheets.Count)
    lw.Move
    curBook.Close False
End Sub