vba筛选后日期前后内容，一起复制

198801273815

表中 代码修改下，筛选后日期前后内容，一起复制,     说明下改哪里,怎么改？

网海遨游

在你原代码基础上，略有改动

Option Explicit
Sub 字典的筛选多行区域()
Dim d As Object, ar, i&, m As Byte, k, Im '声明变量类型
Application.ScreenUpdating = False '禁止刷新
Set d = CreateObject("Scripting.Dictionary") '调用字典
With Sheets("sheet1")
    ar = .Range("a1:i" & .[b65536].End(3).Row) '给数组赋值
    For i = 2 To UBound(ar) '从第2行开始循环，第1行是标题
        If IsDate(ar(i, 2)) Then '如果是时间格式
            m = Month(ar(i, 2)) '获取月份
            If Not d.Exists(m) Then Set d(m) = .[a1:i1] '如果字典键为空，月份当字典的键，B1单元格作为条目
            Set d(m) = Union(d(m), .Range(.Cells(i, 1), .Cells(i, 9))) '如果字典有此键，就将相应单元格链接起来。
        End If
    Next
End With
On Error Resume Next '有错误，继续执行。（防止对工作表命名时，因重名而报错）
For Each k In d.Keys '遍历字典键
    With Sheets(k & "月")
        .[b:b].ClearContents '清除内容
        d(k).Copy .[a1] '复制相应键的条目到[a1]单元格
    End With
    If Err.Number <> 0 Then '程序出错了（无此表），Err.Number的值就不等于零，常用在On Error Resume Next之后
        Sheets.Add after:=Sheets(Sheets.Count) '就在最后新建一个工作表
        With ActiveSheet
            .Name = k & "月" '对新建工作表取名
            d(k).Copy .[a1] '复制相应键的条目到[a1]单元格
        End With
        Err.Clear '清空Err对象，使之变成0
    End If
Next
Sheets("Sheet1").Activate '激活“源”工作表
Set d = Nothing '字典初始化，释放内存
Erase ar '清空数组，释放内存
Application.ScreenUpdating = False '允许刷新
End Sub

网海遨游

修改的代码要审核，发个附件吧。是在你原有代码基础上，稍加改动。

198801273815

网海遨游 发表于 2019-9-23 20:52
在你原代码基础上，略有改动

Option Explicit

感谢，还有注释，太好了

198801273815

网海遨游 发表于 2019-9-23 20:52
在你原代码基础上，略有改动

Option Explicit

说明下改哪里,怎么改？我自己改了下，发现不行，主要是增加了列，不知道怎么改

网海遨游

198801273815 发表于 2019-9-24 16:26
说明下改哪里,怎么改？我自己改了下，发现不行，主要是增加了列，不知道怎么改

你对比一下原代码，就能知道改了的地方，主要是单元格区域有变动