前往小程序,Get更优阅读体验!
立即前往
首页
学习
活动
专区
工具
TVP
发布
社区首页 >专栏 >ExcelVBA每个月取得人员信息备份在一个文件中

ExcelVBA每个月取得人员信息备份在一个文件中

作者头像
哆哆Excel
发布2022-10-25 13:47:32
3680
发布2022-10-25 13:47:32
举报
文章被收录于专栏:哆哆Excel

代码用于自己保存与学习之用

'取得包括全路径的文件名,并根据“农行”两字判别是那一种文件赋值相关的信息

代码语言:javascript
复制
Sub getFileMain()
    Dim fd As FileDialog, MyOb As Object
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    Dim vSelItem As Variant
    row_n = 1
    With fd
        .InitialFileName = ThisWorkbook.Path
        If .Show = -1 Then
            For Each vSelItem In .SelectedItems
            row_n = row_n + 1
           Sheets("main").Cells(row_n, 1) = vSelItem
           If InStr(1, vSelItem, "农行") > 0 Then
           Sheets("main").Cells(row_n, 2) = "编外工资"
           Sheets("main").Cells(row_n, 3) = "金额合计"
           Sheets("main").Cells(row_n, 4) = "1,2,3,4,6,7"
           Else
           Sheets("main").Cells(row_n, 2) = "在职明细"
           Sheets("main").Cells(row_n, 3) = "合计"
           Sheets("main").Cells(row_n, 4) = "1,2,3,4,29,30"
           End If
            Next vSelItem
        Else
        MsgBox "没有选择文件"
        Exit Sub
        End If
    End With
    Set fd = Nothing
End Sub

'取得区工资+编外工资表中的人员信息可用于公积金与个人所得税的用途 '知识点:(1)字典并给item赋值数组的方法,(2)GetObject打开文件(3)Sheets.Add新建工作表(4)Split,Replace,Mid,InStr,Find方法(5)Redim数组

代码语言:javascript
复制
Sub get人员信息()
    Dim dic As Object, mainsht As Worksheet, myobj As Object, addsht As Worksheet
    Dim title_arr, temp_arr, main_arr, col_arr
    Dim end_row, start_n, shtnameStr
    Set dic = CreateObject("scripting.dictionary")
    title_arr = Array("序号", "单位", "姓名", "身份证", "岗位", "职务", "工作表")
    With Sheets("main")
        main_arr = .Range("a1").CurrentRegion
    End With
    total_num = 1
    For i = 2 To UBound(main_arr, 1)
        col_arr = Split(Replace(main_arr(i, 4), ",", ","), ",")
        ReDim temp_arr(1 To UBound(col_arr) + 2)
        'MsgBox UBound(col_arr)
        Set myobj = GetObject(main_arr(i, 1))
        With myobj
            With myobj.Worksheets(main_arr(i, 2))
                end_row = .Cells.Find(main_arr(i, 3), , , , 1, 2).Row - 1
                For rowj = 5 To end_row
                    If .Cells(rowj, 1) <> "" Then
                        For colj = 1 To UBound(temp_arr) - 1
                            temp_arr(colj) = .Cells(rowj, Val(col_arr(colj - 1)))
                        Next colj
                        If colj = UBound(temp_arr) And InStr(1, main_arr(i, 1), "农行") > 0 Then
                            temp_arr(UBound(temp_arr)) = "编外工资表"
                            shtnameStr = Mid(main_arr(i, 1), InStr(1, main_arr(i, 1), "农行") - 8, 8)
                        Else
                            temp_arr(UBound(temp_arr)) = "区工资表"
                        End If
                        dic(total_num) = temp_arr
                        total_num = total_num + 1
                    End If
                Next rowj
            End With
            .Close False
        End With
        Set myobj = Nothing
    Next i
    vtem = Application.Transpose(Application.Transpose(dic.items))
    Set addsht = Sheets.Add(After:=Sheets(Sheets.Count))
    addsht.Name = shtnameStr
    With addsht
        .Range("a1").Resize(, UBound(title_arr) + 1) = title_arr
        .Range("a2").Resize(UBound(vtem, 1), UBound(vtem, 2)).NumberFormatLocal = "@"
        .Range("a2").Resize(UBound(vtem, 1), UBound(vtem, 2)) = vtem
        .Range("a1").CurrentRegion.Columns.AutoFit
        .Range("a1").CurrentRegion.Borders.LineStyle = 1
    End With
End Sub
本文参与 腾讯云自媒体同步曝光计划,分享自微信公众号。
原始发表:2019-08-22,如有侵权请联系 cloudcommunity@tencent.com 删除

本文分享自 哆哆Excel 微信公众号,前往查看

如有侵权,请联系 cloudcommunity@tencent.com 删除。

本文参与 腾讯云自媒体同步曝光计划  ,欢迎热爱写作的你一起参与!

评论
登录后参与评论
0 条评论
热度
最新
推荐阅读
领券
问题归档专栏文章快讯文章归档关键词归档开发者手册归档开发者手册 Section 归档