Excel VBA宏根据日期选择数据并将其移动到新选项卡

Posted 2023-05-08

【中文标题】Excel VBA宏根据日期选择数据并将其移动到新选项卡

【英文标题】：Excel VBA macro to select data based on date and move it to a new tab

【发布时间】：2018-06-06 01:14:40

【问题描述】：

我希望你能帮助我。我不擅长 vba，而您的社区过去提供了很大的帮助。我必须每月运行一份报告，显示我的团队在一个咨询项目中的工作时间。附有丝网印刷 report

大约有 1,000 行，我需要将周结束字段中具有相同日期的行移动到新选项卡。在上面的示例中，结果将是复制到两个选项卡的数据，其中 3/23 记录在一张纸上，3/30 在另一张纸上。我找到了可以根据输入复制数据的宏示例，但不一样，报告每季度更新一次，列出了 9 个不同的周。这会给我一个好的开始

【问题讨论】：

您应该将您的问题编辑为某人需要回答您的问题的内容。报告有多少列？有问题的目标日期是什么？这里有很多不必要的信息。另外，你有没有尝试过？

感谢您的反馈 - 电子表格有 16 列，标题为“周末”的列包含数据。示例电子表格有项目、小时、顾问、周末。我需要将具有相同周结束日期的所有行移动到另一个选项卡，因此如果周结束字段中有 4 个不同的值，我最终会得到 4 个选项卡，每个选项卡上都有值。

【参考方案1】：

Sub TransferReport()

'Check each date
 For Each DateEnd In Sheet15.Columns(4).Cells    'Change Sheet15 refer to your report tab
    If DateEnd.Value = "" Then Exit Sub 'Stop program if no date
    If IsDate(DateEnd.Value) Then
        shtName = Format(DateEnd.Value, "dd.mm")    'Change date to valid tab name

        On Error GoTo errorhandler  'if no Date Sheet, go to errorhandler to create new tab
        If Worksheets(shtName).Range("A2").Value = "" Then
           DateEnd.EntireRow.Copy Destination:=Worksheets(shtName).Range("A2")
           Worksheets(shtName).Range("A1:J1").Columns.AutoFit
        Else
            DateEnd.EntireRow.Copy Destination:=Worksheets(shtName).Range("A1").End(xlDown).Offset(1)
        End If
    End If
Next

Exit Sub
errorhandler:
Sheets.Add After:=Sheets(Sheets.Count) 'Create new tab
ActiveSheet.Name = shtName  'Name tab with date
Sheet15.Rows(1).EntireRow.Copy Destination:=ActiveSheet.Rows(1) 'Copy heading to new tab
Resume
End Sub

【讨论】：

这很完美！谢谢你！只有一个问题 - 如何让新标签的格式和列宽与源标签相同？

自动调整列以适应文本长度。