优化以下代码，使他在对比数据只有一行的情况下就按代码逻辑复制并粘贴那一行数据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

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 pasteSheet As Worksheet

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, "\")) & "\" ' Add "\" at the end of folder path

Set pasteSheet = Nothing ' Set default value for pasteSheet
On Error Resume Next ' Try to set pasteSheet as the worksheet with the same date
Set pasteSheet = wb.Sheets(Format(copyRange.Offset(0, 3).Value, "yyyy-mm-dd"))
On Error GoTo 0 ' Reset error handling

If pasteSheet Is Nothing Then ' If the worksheet with the same date doesn't exist, create one
Set wb = Workbooks.Add
wb.SaveAs folderPath & Format(copyRange.Offset(0, 3).Value, "yyyy-mm-dd") & ".xlsx"
Set pasteSheet = wb.Sheets(1)
Else ' If the worksheet with the same date exists, use it
Set wb = pasteSheet.Parent
End If

copyRange.Resize(i - copyRange.Row, ws.Columns.Count).Copy
pasteSheet.Range("A" & pasteSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1).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, "\")) & "\" ' Add "\" at the end of folder path

Set pasteSheet = Nothing ' Set default value for pasteSheet
On Error Resume Next ' Try to set pasteSheet as the worksheet with the same date
Set pasteSheet = wb.Sheets(Format(copyRange.Offset(0, 3).Value, "yyyy-mm-dd"))
On Error GoTo 0 ' Reset error handling

If pasteSheet Is Nothing Then ' If the worksheet with the same date doesn't exist, create one
Set wb = Workbooks.Add
wb.SaveAs folderPath & Format(copyRange.Offset(0, 3).Value, "yyyy-mm-dd") & ".xlsx"
Set pasteSheet = wb.Sheets(1)
Else ' If the worksheet with the same date exists, use it
Set wb = pasteSheet.Parent
End If

copyRange.Resize(lastRow - copyRange.Row + 1, ws.Columns.Count).Copy
pasteSheet.Range("A" & pasteSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteValues
wb.Save
wb.Close
End If
End Sub