Vba 将日期拆分为新页

我目前正在尝试分割每个日期并为其制作单独的工作表，我在选择每天并将其粘贴到单独的工作表上有点困难。我决定把日期和时间分成不同的列，这样我更容易把它形象化

谢谢你的帮助

“现在看起来怎么样

代码运行后应该如何处理，不要介意B列和C列不同，因为这只是一个示例。

---

这就是我想到的，你使用的方法有一些错误：

-最后一行返回第一行

-您的代码似乎为每个检查的日期都添加了一个新的工作表

-据我所知，sheet.add方法无法与读/写属性.name*组合

我基本上重写了循环结构，只在日期不匹配的情况下添加一张新的工作表。。。。遗憾的是，您无法使用/character:C命名工作表，因此工作表名称类似于12272017，而不是2017年12月27日

另外，您想显示日期和时间。numberformat可以使用以下格式执行此操作：mm/dd/yyyy mm:ss

Sub SortDat_toSheet()
Dim x, y, i, n As Long
Dim wsNam As String
Dim Target, TDate, TRange As Range
Dim Results As Variant
Dim Wks As Worksheet

Set Wks = ActiveSheet
Set Target = Range("A1:D31", Cells(Rows.Count, "A").End(xlUp))
Results = Target.Value
Wks.Columns(1).NumberFormat = "mm/dd/yyyy  mm:ss"
n = 1             'set n to the column with the dates
x = UBound(Results, 1)
y = UBound(Results, 2)
Set TDate = Target(1, n)

For i = 1 To x
wsNam = Results(i, n)
wsNam = NamGen(wsNam)
If Not (i + 1) > x Then
    If Left(Results(i, n), 10) <> Left(Results(i + 1, n), 10) Then
        Sheets.Add After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = wsNam
        Wks.Range(TDate.Address, Target(i, n)).Copy
        Sheets(wsNam).Range("a1").PasteSpecial xlPasteValuesAndNumberFormats
        Sheets(Sheets.Count).Columns(n).AutoFit
        Set TDate = Target(i + 1, n)
    End If
Else
        Sheets.Add After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = wsNam
        Wks.Range(TDate.Address, Target(i, n)).Copy
        Sheets(wsNam).Range("a1").PasteSpecial xlPasteValuesAndNumberFormats
        Sheets(Sheets.Count).Columns(n).AutoFit
End If
Next i
Wks.Activate
Application.CutCopyMode = False
End Sub

Function NamGen(BadNam As String) As String
Dim i As Long
Dim xChar As String
xChar = ""
For i = 1 To 10
    If Mid(BadNam, i, 1) Like "[1234567890]" Then
        xChar = xChar & Mid(BadNam, i, 1)
    End If
Next i
NamGen = xChar
End Function

希望这有帮助！我对VBA有点陌生，所以；D

---

**所以我想你也需要把其他的列转移进来，以匹配日期列？我在VBA中做了一个小技巧：制作一个索引，匹配，匹配公式，将所有单元格的值设置为该公式，它完成所有工作。。。然后将单元格复制并粘贴回原来的值。。。它快而容易

结果用于什么？这是您创建的函数吗？另外，您的行：resultsitter，2.粘贴您正在再次“粘贴”，不确定某个内容的结果是什么，但我看不到您曾将其复制到哪里-原始工作表上的所有内容都应复制到新工作表，以及新工作表上的何处？请使用autofilter记录VBA宏Alt+t，M，R以筛选日期。这将为您提供脚本的基础，在脚本中，您使用autofilter在.@K.Davis上复制工作表。我将结果设置为等于目标值，amd im将每天的数据从第一个单元格复制到新工作表中，直到工作表结束。

Sub SortDat_toSheet()
Dim x, y, i, n As Long
Dim wsNam As String
Dim Target, TDate, TRange As Range
Dim Results As Variant
Dim Wks As Worksheet

Set Wks = ActiveSheet
Set Target = Range("A1:D31", Cells(Rows.Count, "A").End(xlUp))
Results = Target.Value
Wks.Columns(1).NumberFormat = "mm/dd/yyyy  mm:ss"
n = 1             'set n to the column with the dates
x = UBound(Results, 1)
y = UBound(Results, 2)
Set TDate = Target(1, n)

For i = 1 To x
wsNam = Results(i, n)
wsNam = NamGen(wsNam)
If Not (i + 1) > x Then
    If Left(Results(i, n), 10) <> Left(Results(i + 1, n), 10) Then
        Sheets.Add After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = wsNam
        Wks.Range(TDate.Address, Target(i, n)).Copy
        Sheets(wsNam).Range("a1").PasteSpecial xlPasteValuesAndNumberFormats
        Sheets(Sheets.Count).Columns(n).AutoFit
        Set TDate = Target(i + 1, n)
    End If
Else
        Sheets.Add After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = wsNam
        Wks.Range(TDate.Address, Target(i, n)).Copy
        Sheets(wsNam).Range("a1").PasteSpecial xlPasteValuesAndNumberFormats
        Sheets(Sheets.Count).Columns(n).AutoFit
End If
Next i
Wks.Activate
Application.CutCopyMode = False
End Sub

Function NamGen(BadNam As String) As String
Dim i As Long
Dim xChar As String
xChar = ""
For i = 1 To 10
    If Mid(BadNam, i, 1) Like "[1234567890]" Then
        xChar = xChar & Mid(BadNam, i, 1)
    End If
Next i
NamGen = xChar
End Function