请路过大侠指点如何用vba批量保留Excel文件每月最后一天的行数据

xiaofan1999

liulang0808 发表于 2022-12-6 07:57
保留每周最后一天以及每月最后一天

版主您好，保留每周最后一天的代码有问题，运行完后所有数据都是空的，您有时间在帮小弟看一下，谢谢！！！

liulang0808

xiaofan1999 发表于 2022-12-6 08:14
版主您好，保留每周最后一天的代码有问题，运行完后所有数据都是空的，您有时间在帮小弟看一下，谢谢！！ ...

If Weekday(dt) <> 6 Then
具体楼主的最后一天是哪一个，建议根据需求，自己调整看看

gwjkkkkk

应该定义一下最后一天是星期一，还是星期日。。。

xiaofan1999

liulang0808 发表于 2022-12-6 08:46
If Weekday(dt)  6 Then
具体楼主的最后一天是哪一个，建议根据需求，自己调整看看

版主关键就是最后一天不确定，才不好弄，今天分用光了明天一定补上！！！

xiaofan1999

gwjkkkkk 发表于 2022-12-6 09:29
应该定义一下最后一天是星期一，还是星期日。。。

大侠关键就是最后一天不确定，才不好弄，今天分用光了明天一定补上！！！

gwjkkkkk

最后一天是不确认定的，但你要确定每周第一天是星期一还是星期日。。。

xiaofan1999

gwjkkkkk 发表于 2022-12-6 10:29
最后一天是不确认定的，但你要确定每周第一天是星期一还是星期日。。。

每周第一天是星期一

gwjkkkkk

下班回家帮你看看。。。

xiaofan1999

gwjkkkkk 发表于 2022-12-6 11:11
下班回家帮你看看。。。

谢谢，大侠费心了！！！

gwjkkkkk

Sub TEST2() '取每周最后一天
    Dim strFileName$, strPath$, wkb As Workbook
    Dim arr, i&, vKey, dic As Object, t#
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    t = Timer
    strPath = ThisWorkbook.Path & "\"
    strFileName = Dir(strPath & "*.xls*")
    Do Until strFileName = ""
        If strFileName <> ThisWorkbook.Name Then
           Set wkb = Workbooks.Open(strPath & strFileName)
                dic.RemoveAll
                With wkb.Sheets(1)
                  arr = .[A1].CurrentRegion
                  For i = 2 To UBound(arr)
                     vKey = strWeekday(CStr(arr(i, 1)))
                     If Not dic.Exists(vKey) Then
                        dic(vKey) = Array(arr(i, 1), arr(i, 2))
                        Else
                        If Val(Mid(arr(i, 1), 7, 2)) > Val(Mid(dic(vKey)(0), 7, 2)) Then
                            dic(vKey) = Array(arr(i, 1), arr(i, 2))
                        End If
                     End If
                  Next i
                  .[A1].CurrentRegion.Offset(1).Clear
                  .[A2].Resize(dic.Count, 2) = Application.Rept(dic.Items, 1)
                End With
           wkb.Close True
        End If
        strFileName = Dir
    Loop
    Set wkb = Nothing
    Application.ScreenUpdating = True
    MsgBox "执行完毕!_用时:  " & Format(Timer - t, "0.00") & "  秒", 64
End Sub
Function strWeekday$(strTxt$)
Dim str1&
    str1 = CDate(Format(strTxt, "0000-00-00"))
    strWeekday = Mid(strTxt, 1, 4) & "-" & WorksheetFunction.WeekNum(str1, 11)
End Function