Module
Function Shift_Allowance(ShtName As String) 'Application.ScreenUpdating = False Dim TargetStaff As String Dim Sht As Worksheet, Sht0 As Worksheet Dim i As Integer, j As Integer, i0 As Integer, j0 As Integer, j1 As Integer Dim DateRow As Integer Dim iMax As Integer, jMax As Integer Dim Num As Integer Set Sht = Sheets(ShtName) 'Target Sheet Set Sht0 = Sheets("Shift Allowance Form")'/找到日期所在行/ Do i = i + 1 If StrComp(Sht.Cells(i, 1), "name", 1) = 0 Then DateRow = i End If Loop Until DateRow = i'/计算当月天数/ Do jMax = jMax + 1 Loop Until Sht.Cells(DateRow, jMax + 1) = ""'/总人数所在行/ iMax = DateRow Do iMax = iMax + 1 Loop Until Sht.Cells(iMax + 1, 1) = "" And Sht.Cells(iMax + 2, 1) = ""'==================================================================================== i = DateRow 'Selection Row i0 = 13 Do i = i + 1 TargetStaff = Sht.Cells(i, 1) If Staff_Name(TargetStaff) = TargetStaff Then j = 1 Do j = j + 1 '/判断MA及NB/ If InStr(1, Sht.Cells(i, j), "MA", vbTextCompare) Then Sht.Cells(i, j) = "MA" ElseIf InStr(1, Sht.Cells(i, j), "NB", vbTextCompare) Then Sht.Cells(i, j) = "NB" End If '================================================================================================ If InStr(1, "|MA|NB|EB|", "|" & Sht.Cells(i, j) & "|", vbTextCompare) Then '等价于If Sht.Cells(i,j) = "MA" Or Sht.Cells(i,j) = "NB" Or Sht.Cells(i,j) = "EB" With Sht0 Num = Num + 1 .Cells(i0, 1) = Num .Cells(i0, 2) = Staff_ID(TargetStaff) .Cells(i0, 3) = Staff_Name(TargetStaff) .Cells(i0, 10) = Staff_LN(TargetStaff) If Sht.Cells(i, j) = "MA" Then .Cells(i0, 8) = "1st Shift" .Cells(i0, 9) = "7:30 - 16:30" ElseIf Sht.Cells(i, j) = "NB" Then .Cells(i0, 8) = "2nd Shift" .Cells(i0, 9) = "13:00 - 22:00" ElseIf Sht.Cells(i, j) = "EB" Then .Cells(i0, 8) = "3rd Shift" .Cells(i0, 9) = "22:00 - 8:00" End If j0 = j Do j = j + 1 If InStr(1, Sht.Cells(i, j), "MA", vbTextCompare) Then Sht.Cells(i, j) = "MA" ElseIf InStr(1, Sht.Cells(i, j), "NB", vbTextCompare) Then Sht.Cells(i, j) = "NB" End If Loop Until Sht.Cells(i, j0) <> Sht.Cells(i, j) j1 = j - 1 .Cells(i0, 4) = Sht.Cells(DateRow, j0) .Cells(i0, 5) = Sht.Cells(DateRow, j1) .Cells(i0, 7) = j1 - j0 + 1 End With i0 = i0 + 1 Sht0.Rows(i0).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove '插入新一行 End If Loop Until j = jMax + 1 End If Loop Until i = iMax + 1' Application.ScreenUpdating = TrueEnd FunctionFunction Staff_ID(TargetStaff As String) For a = 2 To Sheets("StaffInfo").Range("A" & Rows.Count).End(xlUp).Row If TargetStaff = Sheets("StaffInfo").Cells(a, 2) Then Exit For Next a Staff_ID = Sheets("StaffInfo").Cells(a, 1)End FunctionFunction Staff_Name(TargetStaff As String) For a = 2 To Sheets("StaffInfo").Range("A" & Rows.Count).End(xlUp).Row If TargetStaff = Sheets("StaffInfo").Cells(a, 2) Then Exit For Next a Staff_Name = Sheets("StaffInfo").Cells(a, 2)End FunctionFunction Staff_LN(TargetStaff As String) For a = 2 To Sheets("StaffInfo").Range("A" & Rows.Count).End(xlUp).Row If TargetStaff = Sheets("StaffInfo").Cells(a, 2) Then Exit For Next a Staff_LN = Sheets("StaffInfo").Cells(a, 3)End Function
Module 2 (For Testing)
1 Private Sub CommandButton1_Click() 2 DateRow = 18 3 Set Sht = Sheets(1) 4 Dim arr() 5 Dim arr2() 6 Do 7 jMax = jMax + 1 8 Loop Until Sht.Cells(DateRow, jMax + 1) = "" 9 i = 53 '当前选中的行10 If Staff_Name("Phoebe Li") = "Phoebe Li" Then '判断名字是否相同11 i0 = 1312 i8 = i013 'ReDim arr2(i0 To i8 + 1, 1 To 10)14 j = 1 '日期列原点15 Do16 ReDim arr(i0 To i8, 1 To 10)17 If i0 <> i8 Then18 For a = i0 To i819 For b = 1 To 1020 arr(a, b) = arr2(a, b)21 Next b22 Next a23 End If24 j = j + 1 '日期递加25 '/判断MA及NB/26 If InStr(1, Sht.Cells(i, j), "MA", vbTextCompare) Then27 Sht.Cells(i, j) = "MA"28 ElseIf InStr(1, Sht.Cells(i, j), "NB", vbTextCompare) Then29 Sht.Cells(i, j) = "NB"30 End If31 '================================================================================================32 If InStr(1, "|MA|NB|EB|", "|" & Sht.Cells(i, j) & "|", vbTextCompare) Then33 '等价于If Sht.Cells(i,j) = "MA" Or Sht.Cells(i,j) = "NB" Or Sht.Cells(i,j) = "EB"34 ' With Sht035 Num = Num + 136 arr(i8, 1) = Num37 ' .Cells(i0, 1) = Num38 ' .Cells(i0, 2) = Staff_ID(TargetStaff)39 ' .Cells(i0, 3) = Staff_Name(TargetStaff)40 ' .Cells(i0, 10) = Staff_LN(TargetStaff)41 ' If Sht.Cells(i, j) = "MA" Then42 ' .Cells(i0, 8) = "1st Shift"43 ' .Cells(i0, 9) = "7:30 - 16:30"44 ' ElseIf Sht.Cells(i, j) = "NB" Then45 ' .Cells(i0, 8) = "2nd Shift"46 ' .Cells(i0, 9) = "13:00 - 22:00"47 ' ElseIf Sht.Cells(i, j) = "EB" Then48 ' .Cells(i0, 8) = "3rd Shift"49 ' .Cells(i0, 9) = "22:00 - 8:00"50 ' End If51 If Sht.Cells(i, j) = "MA" Then52 arr(i8, 8) = "1st Shift"53 arr(i8, 9) = "7:30 - 16:30"54 ElseIf Sht.Cells(i, j) = "NB" Then55 arr(i8, 8) = "2nd Shift"56 arr(i8, 9) = "13:00 - 22:00"57 ElseIf Sht.Cells(i, j) = "EB" Then58 arr(i8, 8) = "3rd Shift"59 arr(i8, 9) = "22:00 - 8:00"60 End If61 j0 = j62 Do63 j = j + 164 If InStr(1, Sht.Cells(i, j), "MA", vbTextCompare) Then65 Sht.Cells(i, j) = "MA"66 ElseIf InStr(1, Sht.Cells(i, j), "NB", vbTextCompare) Then67 Sht.Cells(i, j) = "NB"68 End If69 Loop Until Sht.Cells(i, j0) <> Sht.Cells(i, j)70 j1 = j - 171 ' .Cells(i0, 4) = Sht.Cells(DateRow, j0)72 ' .Cells(i0, 5) = Sht.Cells(DateRow, j1)73 ' .Cells(i0, 7) = j1 - j0 + 174 arr(i8, 4) = Sht.Cells(DateRow, j0)75 arr(i8, 5) = Sht.Cells(DateRow, j1)76 arr(i8, 7) = j1 - j0 + 177 ' End With78 ' Sht0.Rows(i0).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove '插入新一行79 ReDim arr2(i0 To i8 + 1, 1 To 10)80 For a = i0 To i881 For b = 1 To 1082 arr2(a, b) = arr(a, b)83 Next b84 Next a85 i8 = i8 + 186 End If87 Loop Until j = jMax + 188 End If89 End Sub