跳转到内容

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

发起与Hycheun3的讨论

发起讨论