User talk:Hycheun3
添加话题外观
Sub CreateResultSheetWithColorFormatting()
Dim wsData As Worksheet, wsNameList As Worksheet, wsResult As Worksheet Dim lastRowData As Long, lastRowName As Long, i As Long, j As Long Dim resultRow As Long, currentRow As Long, lastRow As Long Dim nameToFind As String, startDate As Date, endDate As Date Dim dataDate As Date, prevStart As Date, prevEnd As Date Dim currentColor As Long, prevName As String Dim colorToggle As Boolean, hasMatch As Boolean Dim startDateText As String, endDateText As String, dataDateText As String ' Color constants Const COLOR1 As Long = &HC6EFCE ' Light green Const COLOR2 As Long = &HFFFFFF ' White ' Set worksheets Set wsData = ThisWorkbook.Sheets("Data") Set wsNameList = ThisWorkbook.Sheets("name list") ' Create result sheet Application.DisplayAlerts = False ThisWorkbook.Sheets("Result").Delete Set wsResult = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) wsResult.Name = "Result" Application.DisplayAlerts = True ' Set headers With wsResult .Range("A1:F1").Value = wsData.Range("A1:F1").Value .Range("G1").Value = "Start Date" .Range("H1").Value = "End Date" .Range("A1:H1").Interior.Color = RGB(200, 200, 200) .Range("A1:H1").Font.Bold = True End With ' Get last rows lastRowData = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row lastRowName = wsNameList.Cells(wsNameList.Rows.Count, "A").End(xlUp).Row ' Initialize variables resultRow = 2 colorToggle = True prevName = "" prevStart = DateSerial(1900, 1, 1) prevEnd = DateSerial(1900, 1, 1) ' Optimize performance Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ' Process each name in name list For i = 2 To lastRowName nameToFind = Trim(wsNameList.Cells(i, 1).Value) ' Handle name list dates startDateText = wsNameList.Cells(i, 2).Text endDateText = wsNameList.Cells(i, 3).Text startDate = ConvertTextToDate(startDateText) endDate = ConvertTextToDate(endDateText) ' Toggle color when criteria change If prevName <> nameToFind Or prevStart <> startDate Or prevEnd <> endDate Then colorToggle = Not colorToggle prevName = nameToFind prevStart = startDate prevEnd = endDate End If currentColor = IIf(colorToggle, COLOR1, COLOR2) hasMatch = False ' Search data sheet For j = 2 To lastRowData If Trim(wsData.Cells(j, 2).Value) = nameToFind Then ' Handle data sheet date dataDateText = wsData.Cells(j, 1).Text dataDate = ConvertTextToDate(dataDateText) ' Date range check If (startDate = 0 Or dataDate >= startDate) And _ (endDate = 0 Or dataDate <= endDate) Then ' Copy data with date conversion wsData.Rows(j).Copy Destination:=wsResult.Rows(resultRow) wsResult.Cells(resultRow, 1).Value = dataDate ' Override with converted date ' Add date range With wsResult .Cells(resultRow, 7).Value = startDate .Cells(resultRow, 8).Value = endDate .Rows(resultRow).Interior.Color = currentColor End With resultRow = resultRow + 1 hasMatch = True End If End If Next j ' Handle no matches If Not hasMatch Then With wsResult .Cells(resultRow, 1).Value = nameToFind .Range(.Cells(resultRow, 2), .Cells(resultRow, 6)).Merge .Cells(resultRow, 2).Value = "no data found" .Cells(resultRow, 2).HorizontalAlignment = xlCenter .Cells(resultRow, 7).Value = startDate .Cells(resultRow, 8).Value = endDate .Rows(resultRow).Interior.Color = currentColor End With resultRow = resultRow + 1 End If Next i ' Final formatting lastRow = wsResult.Cells(wsResult.Rows.Count, "A").End(xlUp).Row ' Format borders With wsResult.Range("A1:H" & lastRow).Borders .LineStyle = xlContinuous .Color = RGB(100, 100, 100) .Weight = xlThin End With ' Format merged cells For currentRow = 2 To lastRow If wsResult.Cells(currentRow, 2).Value = "no data found" Then wsResult.Range("B" & currentRow & ":F" & currentRow).Merge End If Next currentRow ' Apply date formats With wsResult .Columns("A").NumberFormat = "dd-mm-yyyy" .Columns("G:H").NumberFormat = "dd-mm-yyyy" .Columns("A:H").AutoFit End With ' Cleanup Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox "Processed " & (resultRow - 2) & " entries successfully.", vbInformation
End Sub
Function ConvertTextToDate(dateText As String) As Date
Dim parts() As String Dim dayPart As Integer, monthPart As Integer, yearPart As Integer On Error Resume Next ' Try direct conversion first ConvertTextToDate = CDate(dateText) If Err.Number = 0 Then Exit Function Err.Clear ' Try splitting by common delimiters If InStr(dateText, "/") > 0 Then parts = Split(dateText, "/") ElseIf InStr(dateText, "-") > 0 Then parts = Split(dateText, "-") Else ConvertTextToDate = 0 Exit Function End If If UBound(parts) <> 2 Then ConvertTextToDate = 0 Exit Function End If ' Validate numeric parts If Not (IsNumeric(parts(0)) And IsNumeric(parts(1)) And IsNumeric(parts(2))) Then ConvertTextToDate = 0 Exit Function End If dayPart = CInt(parts(0)) monthPart = CInt(parts(1)) yearPart = CInt(parts(2)) ' Fix 2-digit years If yearPart < 100 Then yearPart = yearPart + 2000 ' Try different date configurations If dayPart > 31 And monthPart <= 12 Then ' Clearly mm/dd/yyyy format ConvertTextToDate = DateSerial(yearPart, monthPart, dayPart) ElseIf monthPart > 12 And dayPart <= 31 Then ' Clearly dd/mm/yyyy format ConvertTextToDate = DateSerial(yearPart, dayPart, monthPart) Else ' Ambiguous - try both formats ConvertTextToDate = DateSerial(yearPart, monthPart, dayPart) If Err.Number <> 0 Then Err.Clear ConvertTextToDate = DateSerial(yearPart, dayPart, monthPart) End If End If If Err.Number <> 0 Then ConvertTextToDate = 0 On Error GoTo 0
End Function