User: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

Dim currentColor As Long

Dim seriesNumber As Long

Dim hasMatch As Boolean

' 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

On Error Resume Next

ThisWorkbook.Sheets("Result").Delete

On Error GoTo 0

Application.DisplayAlerts = True

Set wsResult = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))

wsResult.Name = "Result"

' Set headers with new Series Number column

With wsResult

.Range("A1:F1").Value = wsData.Range("A1:F1").Value

.Range("G1").Value = "Start Date"

.Range("H1").Value = "End Date"

.Range("I1").Value = "Series Number"

.Range("A1:I1").Interior.Color = RGB(200, 200, 200) ' Gray background

.Range("A1:I1").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

' 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)

startDate = wsNameList.Cells(i, 2).Value

endDate = wsNameList.Cells(i, 3).Value

seriesNumber = wsNameList.Cells(i, 4).Value ' Get series number (numerical)

' Determine color based on series number

currentColor = IIf(seriesNumber Mod 2 = 1, COLOR1, COLOR2)

hasMatch = False

' Search data sheet for matches

For j = 2 To lastRowData

If Trim(wsData.Cells(j, 2).Value) = nameToFind Then

dataDate = wsData.Cells(j, 1).Value

' Check date range

If (startDate = 0 Or dataDate >= startDate) And _

(endDate = 0 Or dataDate <= endDate) Then

' Copy matching row

wsData.Rows(j).Copy Destination:=wsResult.Rows(resultRow)

' Add date range, series number and formatting

With wsResult

.Cells(resultRow, 7).Value = startDate

.Cells(resultRow, 8).Value = endDate

.Cells(resultRow, 9).Value = seriesNumber

.Rows(resultRow).Interior.Color = currentColor

End With

resultRow = resultRow + 1

hasMatch = True

End If

Next j

' Handle no-match case

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

.Cells(resultRow, 9).Value = seriesNumber

.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

' Set borders (extended to column I)

With wsResult.Range("A1:I" & lastRow).Borders

.LineStyle = xlContinuous

.Color = RGB(100, 100, 100)

.Weight = xlThin

End With

' Format merged cells and dates

For currentRow = 2 To lastRow

If wsResult.Cells(currentRow, 2).Value = "no data found" Then

wsResult.Range("B" & currentRow & ":F" & currentRow).Merge

wsResult.Cells(currentRow, 2).HorizontalAlignment = xlCenter

End If

Next currentRow

' Auto-fit and format columns (include column I)

With wsResult

.Columns("A:I").AutoFit

.Columns("A").NumberFormat = "dd-mm-yyyy"

.Columns("G:H").NumberFormat = "dd-mm-yyyy"

.Columns("I").NumberFormat = "0" ' Format series number as plain number

End With

' Restore settings

Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic

MsgBox "Processing complete. " & (resultRow - 2) & " rows processed.", vbInformation

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub InsertCompensationWithTotalNegative()

Dim ws As Worksheet

Set ws = ThisWorkbook.Sheets("Sheet1") ' Change to your sheet name

' Find last row starting from row 3

Dim lastRow As Long

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

If lastRow < 3 Then Exit Sub ' No data

' Collection to store group information

Dim groups As Collection

Set groups = New Collection

' Identify consecutive name groups and calculate negative sums

Dim groupStart As Long

groupStart = 3 ' Data starts at row 3

Dim currentName As String

currentName = Trim(ws.Cells(3, "C").Value)

Dim groupData As Object

For i = 4 To lastRow + 1

Dim nameVal As String

If i <= lastRow Then nameVal = Trim(ws.Cells(i, "C").Value)

' Process group when name changes or at end of data

If i > lastRow Or nameVal <> currentName Then

Set groupData = CreateObject("Scripting.Dictionary")

groupData.Add "startRow", groupStart

groupData.Add "endRow", i - 1

groupData.Add "name", currentName

' Calculate total negative for group

Dim totalNegative As Double

totalNegative = 0

For j = groupStart To i - 1

Dim colIVal As Variant

colIVal = ws.Cells(j, "I").Value

If IsNumeric(colIVal) And colIVal < 0 Then

totalNegative = totalNegative + colIVal

End If

Next j

groupData.Add "totalNegative", totalNegative

groups.Add groupData

If i > lastRow Then Exit For

groupStart = i

currentName = nameVal

End If

Next i

' Insert compensation rows from last group to first

Dim groupIdx As Long

For groupIdx = groups.Count To 1 Step -1

Set groupData = groups(groupIdx)

totalNegative = groupData("totalNegative")

If totalNegative < 0 Then

Dim insertRow As Long

insertRow = groupData("endRow") + 1

' Insert new row

ws.Rows(insertRow).Insert Shift:=xlDown

' Copy ID, Name, Team, Rank from first group row

ws.Range("B" & groupData("startRow") & ":E" & groupData("startRow")).Copy _

Destination:=ws.Range("B" & insertRow)

' Set compensation values

With ws.Rows(insertRow)

.Cells(6).Value = "time earn compensate by time earn" ' Reason (F)

.Cells(7).Value = Abs(totalNegative) ' Time earn (G)

.Cells(8).Value = totalNegative ' DSOA (H)

.Cells(9).ClearContents ' Clear minus DSOA (I)

.Cells(1).ClearContents ' Clear SN (A)

End With

End If

Next groupIdx

MsgBox "Inserted " & groups.Count & " compensation rows."

End Sub