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

xiaofan1999

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

liulang0808

楼主是要将每个文件不是每月最后一天的数据都删除吗？

xiaofan1999

liulang0808 发表于 2022-12-5 21:50
楼主是要将每个文件不是每月最后一天的数据都删除吗？

是，就保留每月最后一天数据，

gwjkkkkk

请楼主参考附件。。。

xiaofan1999

gwjkkkkk 发表于 2022-12-5 22:55
请楼主参考附件。。。

大侠，您代码太高深了，小弟本想举一反三，但是您思路还是理解不了，这种情况能把每周最后一天留下吗？

xiaofan1999

liulang0808 发表于 2022-12-5 21:50
楼主是要将每个文件不是每月最后一天的数据都删除吗？

谢谢版主提醒小弟没将要求说明白！！！

liulang0808

Sub 按钮1_Click()
    Set fso = CreateObject("scripting.filesystemobject")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each f In fso.getfolder(ThisWorkbook.Path).Files
        If InStr(f.Name, ThisWorkbook.Name) = 0 Then
            With Workbooks.Open(f)
                Set Rng = Nothing
                With .Sheets(1)
                    r = .Cells(Rows.Count, 1).End(3).Row
                    arr = .[a1].Resize(r)
                    For J = 2 To UBound(arr)
                        dt = CDate(Left(arr(J, 1), 4) & "-" & Mid(arr(J, 1), 5, 2) & "-" & Right(arr(J, 1), 2))
                        If Month(dt) = Month(dt + 1) Then
                            If Rng Is Nothing Then
                                Set Rng = .Cells(J, 1)
                            Else
                                Set Rng = Union(Rng, .Cells(J, 1))
                            End If
                        End If
                    Next J
                    If Not Rng Is Nothing Then Rng.EntireRow.Delete
                End With
                .Save
                .Close True
            End With
        End If
    Next f
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

liulang0808

保留每月最后一天的数据

liulang0808

Sub 按钮2_Click()
    Set fso = CreateObject("scripting.filesystemobject")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each f In fso.getfolder(ThisWorkbook.Path).Files
        If InStr(f.Name, ThisWorkbook.Name) = 0 Then
            With Workbooks.Open(f)
                Set Rng = Nothing
                With .Sheets(1)
                    r = .Cells(Rows.Count, 1).End(3).Row
                    arr = .[a1].Resize(r)
                    For J = 2 To UBound(arr)
                        dt = CDate(Left(arr(J, 1), 4) & "-" & Mid(arr(J, 1), 5, 2) & "-" & Right(arr(J, 1), 2))
                        If Weekday(dt) <> 1 Then
                            If Rng Is Nothing Then
                                Set Rng = .Cells(J, 1)
                            Else
                                Set Rng = Union(Rng, .Cells(J, 1))
                            End If
                        End If
                    Next J
                    If Not Rng Is Nothing Then Rng.EntireRow.Delete
                End With
                .Save
                .Close True
            End With
        End If
    Next f
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
保留每周最后一天的数据

liulang0808

保留每周最后一天以及每月最后一天