请帮我优化以下代码，他有个缺陷就是当Excel表格只有一行的时候他不会执行复制粘贴。我需要改成在只有一行数据的时候也按代码复制粘贴的逻辑进行。Sub CopySameDay() Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim copyRange As Range Dim pasteRange As Range Dim wb As Workbook Dim folderPath As String Dim fileName As String Dim asteRange As Range Set ws = ActiveSheet lastRow = ws.Cells(Rows.Count, "D").End(xlUp).Row For i = 2 To lastRow If Format(ws.Range("D" & i).Value, "yyyy-mm-dd") = Format(ws.Range("D" & i - 1).Value, "yyyy-mm-dd") And ws.Range("B" & i).Value = ws.Range("B" & i - 1).Value Then If copyRange Is Nothing Then Set copyRange = ws.Range("A" & i - 1) End If Set pasteRange = ws.Range("A" & i) Else If Not copyRange Is Nothing Then folderPath = Left(ThisWorkbook.FullName, InStrRev(ThisWorkbook.FullName, "\")) Set asteRange = ws.Range("B" & i - 1) fileName = asteRange.Value & ".xlsx" If Dir(folderPath & fileName) = "" Then Set wb = Workbooks.Add wb.SaveAs folderPath & fileName Else Set wb = Workbooks.Open(folderPath & fileName) End If wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count)).Name = Format(copyRange.Offset(0, 3).Value, "yyyy-mm-dd") copyRange.Resize(i - copyRange.Row, ws.Columns.Count).Copy wb.Sheets(wb.Sheets.Count).Range("A1").PasteSpecial xlPasteValues wb.Save wb.Close Set copyRange = Nothing End If End If Next i If Not copyRange Is Nothing Then folderPath = Left(ThisWorkbook.FullName, InStrRev(ThisWorkbook.FullName, "\")) Set asteRange = ws.Range("B" & i - 1) fileName = asteRange.Value & ".xlsx" If Dir(folderPath & fileName) = "" Then Set wb = Workbooks.Add wb.SaveAs folderPath & fileName Else Set wb = Workbooks.Open(folderPath & fileName) End If wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count)).Name = Format(copyRange.Offset(0, 3).Value, "yyyy-mm-dd") copyRange.Resize(lastRow - copyRange.Row + 1, ws.Columns.Count).Copy wb.Sheets(wb.Sheets.Count).Range("A1").PasteSpecial xlPasteValues wb.Save wb.Close End If End Sub

在代码中添加一些逻辑，以便在只有一行数据的情况下也按照复制粘贴的逻辑进行。可以将以下代码添加到第6行的后面：

'如果只有一行数据，将复制范围设置为该行
If lastRow = 1 Then
Set copyRange = ws.Range("A1")
End If

这样，当Excel表格只有一行数据时，代码会将复制范围设置为该行，以便进行复制粘贴操作。完整的代码如下：

Sub CopySameDay()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Dim copyRange As Range
Dim pasteRange As Range
Dim wb As Workbook
Dim folderPath As String
Dim fileName As String
Dim asteRange As Range

Set ws = ActiveSheet

lastRow = ws.Cells(Rows.Count, "D").End(xlUp).Row

'如果只有一行数据，将复制范围设置为该行
If lastRow = 1 Then
Set copyRange = ws.Range("A1")
End If

For i = 2 To lastRow
If Format(ws.Range("D" & i).Value, "yyyy-mm-dd") = Format(ws.Range("D" & i - 1).Value, "yyyy-mm-dd") And ws.Range("B" & i).Value = ws.Range("B" & i - 1).Value Then
If copyRange Is Nothing Then
Set copyRange = ws.Range("A" & i - 1)
End If
Set pasteRange = ws.Range("A" & i)
Else
If Not copyRange Is Nothing Then
folderPath = Left(ThisWorkbook.FullName, InStrRev(ThisWorkbook.FullName, "\"))

Set asteRange = ws.Range("B" & i - 1)

fileName = asteRange.Value & ".xlsx"

If Dir(folderPath & fileName) = "" Then
Set wb = Workbooks.Add
wb.SaveAs folderPath & fileName
Else
Set wb = Workbooks.Open(folderPath & fileName)
End If

wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count)).Name = Format(copyRange.Offset(0, 3).Value, "yyyy-mm-dd")

copyRange.Resize(i - copyRange.Row, ws.Columns.Count).Copy
wb.Sheets(wb.Sheets.Count).Range("A1").PasteSpecial xlPasteValues

wb.Save
wb.Close

Set copyRange = Nothing
End If
End If
Next i

If Not copyRange Is Nothing Then
folderPath = Left(ThisWorkbook.FullName, InStrRev(ThisWorkbook.FullName, "\"))

Set asteRange = ws.Range("B" & i - 1)

fileName = asteRange.Value & ".xlsx"

If Dir(folderPath & fileName) = "" Then
Set wb = Workbooks.Add
wb.SaveAs folderPath & fileName
Else
Set wb = Workbooks.Open(folderPath & fileName)
End If

wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count)).Name = Format(copyRange.Offset(0, 3).Value, "yyyy-mm-dd")

copyRange.Resize(lastRow - copyRange.Row + 1, ws.Columns.Count).Copy
wb.Sheets(wb.Sheets.Count).Range("A1").PasteSpecial xlPasteValues

wb.Save
wb.Close
End If

End Sub