年月日时按月分表

xing_chen

老师，有表中有日期列，但日期的表达式为年月日时，我希望按月分割为各个月表，敬请老师赐教。谢谢！

fzxba

年月日时按月分表.rar (29.54 KB, 下载次数: 15)

2023-1-9 15:51 上传

点击文件名下载附件

ykcbf1100

总表按月拆分。

xing_chen

ykcbf1100 发表于 2023-1-9 15:57
总表按月拆分。

谢谢老师！运行如愿！
老师！疫情期间身体保重
另，花在旅途，到时献上

xing_chen

fzxba 发表于 2023-1-9 15:51

谢谢老师！运行如愿！
老师！疫情期间，身体保重。
另，抱歉，花在旅途，到时献上

supermouse24

Sub 按月提取数据()
    arr = [a1].CurrentRegion.Value
   
    For isheet = 1 To Worksheets.Count      '清除内容
        If Worksheets(isheet).Name <> "原表" Then
            With Worksheets(isheet)
                brr = .[a1].CurrentRegion.Value
                .[a1].Resize(UBound(brr, 1), UBound(brr, 2)).Offset(1, 0).Clear
            End With
        End If
    Next
   
   
   
    For irow = 2 To UBound(arr, 1)
        month_ = Month(arr(irow, 9))
        month_str = CStr(month_) '月份提取
        Set sht = Worksheets(month_str)
        With sht
            endrow = .[a1].End(xlDown).Row + 1
            If endrow = 65537 Then
                endrow = 2
            End If
            Cells(irow, 1).Resize(1, UBound(arr, 2)).Copy .Cells(endrow, 1)
        End With
    Next
End Sub

我用起来有点卡，不知道为什么

LIUZHU

JS宏方案

LIUZHU

附件请测试，WPS

xing_chen

supermouse24 发表于 2023-1-9 16:29
Sub 按月提取数据()
    arr = [a1].CurrentRegion.Value
   

谢谢老师。但有黄色，请看看问题出在哪里？

xing_chen

LIUZHU 发表于 2023-1-9 16:31
附件请测试，WPS

谢谢老师！不过，我电脑上未安装WPS，无法验证。
抱歉！花在路途，到时献上