How make dimensions horizontal and vertical in VBA code?

[ladimirabdala]

I've tried make simple dimensions in VBA but not work...

I use the aligned dimensions, some times works well, some times not.

Dim Dimobj As AcadDimension
Set Dimobj = ThisDrawing.PaperSpace.AddDimAligned(Point1, Point2, Point3)

I cant find "AddDimHoriz" for example...

I looking for Horizontal or Vertical only.

Thanks for the answer....

Ladimir Abdala - Thyssenkrupp

[ladimirabdala]

Linear dimensions are actually rotated dimensions with an angle of 0 or 90.
In radian angle of course...

'horizontal 0 degrees
Set Dimobj = ThisDrawing.PaperSpace.AddDimRotated(Point1, Point2, Point3,0)

'vertical 90 degrees
Set Dimobj = ThisDrawing.PaperSpace.AddDimRotated(Point1, Point2, Point3, 1.570796)

THX.

Ladimir Abdala
System CAD Analyst

[zsolti_sdd]

for what is  point 3 ???

[Alfred.NESWADBA · Accepted solution]

Hi,

>> for what is  point 3 ???

When you have that code in your VBA-editor position the cursor over the word "AddDimRotated", on click to be in text edit mode ... and now press <F1>.

This brings you to the help with the signature of that function and description(s) for each parameter.

In that case then help shows (in blue the third parameter you looked for):

VBA: 

RetVal = object.AddDimRotated(XLine1Point, XLine2Point, DimLineLocation, RotationAngle)object 
Type: Block, ModelSpace, PaperSpace 

The object this method applies to. 

XLine1Point 
   Access: Input-only 
   Type: Variant (three-element array of doubles) 
   The 3D WCS coordinates specifying the first end of the linear dimension to be measured. This is where the first extension line will be attached. 

XLine2Point 
   Access: Input-only 
   Type: Variant (three-element array of doubles) 
   The 3D WCS coordinates specifying the second end of the linear dimension to be measured. This is where the second extension line will be attached. 

DimLineLocation 
   Access: Input-only 
   Type: Variant (three-element array of doubles) 
   The 3D WCS coordinates specifying a point on the dimension line. This will define the placement of the dimension line and the dimension text. 

RotationAngle 
   Access: Input-only 
   Type: Double 
   The angle, in radians, of rotation displaying the linear dimension.

- alfred -

[buianhtuan.cdt]

'Setting Sheetname
    Public Const DBSheetname As String = "ƒf[ƒ^ƒx[ƒX"
    Public Const StaffManagerSheetname As String = "lˆõŠÇ—"
    Public Const ProjectSheetname As String = "ˆÄŒŠÇ—"
    
    
    Public Const GroupSheetname As String = "ƒOƒ‹[ƒv‘S‘Ì"
    Public DBWS As Worksheet
    Public StaffManagerWS As Worksheet
    Public ProjectManagerWS As Worksheet
    Public GroupWS As Worksheet
    Public StaffManagerArr As Variant
Sub TBS101_CreatGroupSheet()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
'Set worksheet
    Call TBFH123_Call_SetWorksheet
'Get Year, Month From SystemDate
    Dim SystemYear As String: SystemYear = "2021"
    Dim SystemMonth As String: SystemMonth = "4"
'Get Year, Month From DataBase
    Dim DBYearMonth(0 To 11, 0 To 1) As String
    DBYearMonth(0, 0) = "2021":     DBYearMonth(0, 1) = "1"
    DBYearMonth(1, 0) = "2021":     DBYearMonth(1, 1) = "2"
    DBYearMonth(2, 0) = "2021":     DBYearMonth(2, 1) = "3"
    DBYearMonth(3, 0) = "2021":     DBYearMonth(3, 1) = "4"
    DBYearMonth(4, 0) = "2021":     DBYearMonth(4, 1) = "5"
    DBYearMonth(5, 0) = "2021":     DBYearMonth(5, 1) = "6"
    DBYearMonth(6, 0) = "2021":     DBYearMonth(6, 1) = "7"
    DBYearMonth(7, 0) = "2021":     DBYearMonth(7, 1) = "8"
    DBYearMonth(8, 0) = "2021":     DBYearMonth(8, 1) = "9"
    DBYearMonth(9, 0) = "2021":     DBYearMonth(9, 1) = "10"
    DBYearMonth(10, 0) = "2021":    DBYearMonth(10, 1) = "11"
    DBYearMonth(11, 0) = "2021":    DBYearMonth(11, 1) = "12"
    Call TBFH114_Call_CreatYYYYMMArrFromDBYearMonth(DBYearMonth)
'Check SystemYearSystemMonth is in DBYearMonth
    Dim IsInDBYearMonth As Boolean
    IsInDBYearMonth = TBFH113_Check2ValueIsInArr2Chieu_NumberOrString(DBYearMonth, SystemYear, 0, SystemMonth, 1)
    If IsInDBYearMonth = True Then
        SystemMonth = WorksheetFunction.Text(SystemMonth, "00")
        TBUF1_YYYYMM = SystemYear & "." & SystemMonth
    Else
        TBUF1_YYYYMM = YYYYMMArr(UBound(YYYYMMArr))
    End If
'Get StaffName From PCNo
    Dim StaffName As String
    StaffName = "TUAN"
'Get GroupNo From StaffName
    Dim GroupNo As String
    Dim GroupName As String
    GroupNo = TBFH105_GetStaffInformationFromPCNo_StaffID_StaffName(StaffName, "FromName", "GNo")
    If GroupNo = "" Then GroupNo = "1G"
    GroupName = TBFH112_DefineGroupNameFromGroupNo(GroupNo)
'Set TBUF1_GroupNo, TBUF1_Title
    TBUF1_Title = GroupName
    TBUF1_GroupNo = GroupNo
'Get Information From UserForm
    TBUF1_GroupSheet.Show
    If TBUF1_YYYYMM = "" Then
        GoTo GoToExitSub
    Else
        Call TBFH115_Call_DefineYearMonthFromYYYYMM(TBUF1_YYYYMM, TBUF1_Year, TBUF1_Month)
    End If
'Filter Data in Database by GroupNo,TBUF1_Year, TBUF1_Month
    Dim GetFilterData As Variant
    Dim FilterData() As String
    GetFilterData = TBFH116_FilterDataInDataBaseByGroupNo_Year_Month(TBUF1_Year, TBUF1_Month, TBUF1_GroupNo)
    If VarType(GetFilterData) = vbBoolean Then
        MsgBox "Err:No Data"
        GoTo GoToExitSub
    Else
        FilterData = GetFilterData
    End If
'Creat and Sort FilterProjectNameList
    Dim ProjectNameList As Variant
    Call TBFH117_Call_CreatProjectNameListFromArr(FilterData, ProjectNameList)
'Clear Old Data
    Call TBFH124_Call_GroupSheet_ClearOldData
'Write GroupSheetNote
    Call TBFH125_Call_GroupSheet_WriteNote(TBUF1_Year, TBUF1_Month)
'Write Group StaffName
    Call TBFH126_Call_WriteGroupStaffname(TBUF1_GroupNo)
'Write ProjectName
    Call TBFH129_Call_GroupSheet_WriteProjectName(ProjectNameList)
'Write Data
    Call TBFH130_Call_GroupSheet_WriteData(FilterData)
'Hide Empty Row
    Call TBFH136_Call_GroupSheet_HideEmptyRow
GoToExitSub:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    MsgBox "Finish"
End Sub

[buianhtuan.cdt]

Public TBUF1_Year As String
Public TBUF1_Month As String
Public TBUF1_GroupNo As String
Public TBUF1_Title As String
Public YYYYMMArr() As String
Public TBUF1_YYYYMM As String

Function TBFH121_Call_RemoveListLoaiTruFromProjectNameList(ProjectNameList As Variant, ListLoaiTru As Variant)
    Dim EachProjectName As String
    Dim IsInList As Boolean
    Dim Result() As String
    For i = LBound(ProjectNameList) To UBound(ProjectNameList)
        EachProjectName = ProjectNameList(i)
        IsInList = HCF4086_IsInArr1Chieu_NumberOrString(ListLoaiTru, EachProjectName)
        If IsInList = False Then
            ReDim Preserve Result(0 To k)
            Result(k) = EachProjectName
            k = k + 1
        End If
    Next
    ProjectNameList = Result
End Function
Function Func000Array03FilterArrWithText(Arr As Variant, StrFilter As String, FilterColumn As Integer) As Variant
' Loc mang 2 chieu voi StrFilter va FilterColumn

Dim FilterArr() As Variant
'Neu Arr rong thi thoat function
If Func70IsEmptyArray(Arr) = True Then GoTo ExitFunc

'Tao TmpArr de luu tru so hang thoa man dieu kien
Dim TmpArr() As Variant
Dim TmpValue As Variant
Dim k As Integer
Dim i As Integer
For i = LBound(Arr) To UBound(Arr)
    TmpValue = Arr(i, FilterColumn)
    If TmpValue = StrFilter Then
        ReDim Preserve TmpArr(0 To k)
        TmpArr(k) = i
        k = k + 1
    End If
Next

'Neu k tim thay gia tri phu hop thi thoat function
If Func70IsEmptyArray(TmpArr) = True Then GoTo ExitFunc
'Tao Arr ket qua

Dim FilterArrRow As Integer
Dim FilterArrColumn As Integer
FilterArrRow = UBound(TmpArr)
FilterArrColumn = UBound(Arr, 2)
ReDim FilterArr(0 To FilterArrRow, 0 To FilterArrColumn)
For i = LBound(TmpArr) To UBound(TmpArr)
    TmpValue = TmpArr(i)
    For k = LBound(FilterArr, 2) To UBound(FilterArr, 2)
        FilterArr(i, k) = Arr(TmpValue, k)
    Next
Next
ExitFunc:
Func000Array03FilterArrWithText = FilterArr

End Function

Function Func000Array04CrearArrFromRange(WS As Worksheet, MainColumnLetter As String, ColumnFromLetter As String, ColumnToLetter As String, RowFrom As Integer) As Variant
' Tao mang 2 chieu tu Range
Dim Arr() As Variant

'Define Column no
Dim ColumnFromNo As Integer
Dim ColumnToNo As Integer
Dim MainColumnNo As Integer
ColumnFromNo = Func29ConvertColumnLetterToNumber(ColumnFromLetter)
ColumnToNo = Func29ConvertColumnLetterToNumber(ColumnToLetter)
MainColumnNo = Func29ConvertColumnLetterToNumber(MainColumnLetter)

'Define EndRow no, neu k co du lieu thi thoat
Dim EndRow As Integer
EndRow = WS.Cells(Rows.Count, MainColumnNo).End(xlUp).Row
If EndRow < RowFrom Then Exit Function

'Define Arr TotalColumn va TotalRow
Dim ArrTotalColumn As Integer
Dim ArrTotalRow As Integer
Dim ArrColumn As Integer
Dim ArrRow As Integer
Dim TmpValue As String
ArrTotalColumn = ColumnToNo - ColumnFromNo
ArrTotalRow = EndRow - RowFrom
ReDim Arr(0 To ArrTotalRow, 0 To ArrTotalColumn)
For i = RowFrom To EndRow
    ArrRow = i - RowFrom
    For k = ColumnFromNo To ColumnToNo
        ArrColumn = k - ColumnFromNo
        TmpValue = WS.Cells(i, k).Value
        Arr(ArrRow, ArrColumn) = TmpValue
    Next
Next

Func000Array04CrearArrFromRange = Arr
End Function
Function Func000Array01Lay1DongOMang2Chieu(MotherArr As Variant, RowNo As Integer) As Variant
'Function lay 1 dong trong mang 2 chieu
Dim SonArr() As Variant
For i = LBound(MotherArr, 2) To UBound(MotherArr, 2)
    ReDim Preserve SonArr(0 To i)
    SonArr(i) = MotherArr(RowNo, i)
Next
Func000Array01Lay1DongOMang2Chieu = SonArr
End Function
Function Func000Array02WriteArr1ChieuToRange(WriteArr As Variant, WS As Worksheet, StrCell As String, HorizonVertical As String)
' Ghi du lieu cua mang 1 chieu vao excel theo 2 huong ngang hoac doc
'Neu WriteArr rong thi thoat function
If Func70IsEmptyArray(WriteArr) = True Then Exit Function
'Define ColumnPlus va RowPlus
Dim ColumnPlus As Integer
Dim RowPlus As Integer
Select Case HorizonVertical
    Case "Horizon"
        RowPlus = 0
        ColumnPlus = 1
    Case "Vertical"
        RowPlus = 1
        ColumnPlus = 0
End Select

'Define CellRow and CellColumn from StrCell
Dim Range As Range
Set Range = WS.Range(StrCell)
Dim CellRow As Integer
Dim CellColumn As Integer
CellRow = Range.Row
CellColumn = Range.Column
'Write Data
Dim g, h As Integer
For i = LBound(WriteArr) To UBound(WriteArr)
    WS.Cells(CellRow + g, CellColumn + h).Value = WriteArr(i)
    g = g + RowPlus
    h = h + ColumnPlus
Next
End Function
Function HCF4068_SortArrAtoZ_Arr2Chieu(Arr As Variant, SortRowNo As Integer, StringNumberMode As String) As Variant
' Sap xep cac phan tu cua mang theo thu tu tu A den Z
'Check input
    If Func70IsEmptyArray(Arr) = True Then Exit Function
    If SortRowNo > UBound(Arr, 2) Then Exit Function
    If UBound(Arr) - LBound(Arr) = 0 Then Exit Function
    Dim TmpArr As Variant
    TmpArr = Arr

    Dim TmpValue As Variant
    Dim SmallValue As Variant
    Dim LargeValue As Variant
    Dim Hoandoi As Boolean
    
    For i = LBound(TmpArr, 1) To UBound(TmpArr, 1)
        For k = i + 1 To UBound(TmpArr, 1)
        Hoandoi = False
        SmallValue = TmpArr(i, SortRowNo)
            LargeValue = TmpArr(k, SortRowNo)
            Select Case StringNumberMode
                Case "String"
                    If StrComp(SmallValue, LargeValue) = 1 Then Hoandoi = True
                Case "Number"
                    If SmallValue > LargeValue Then Hoandoi = True
            End Select
            If Hoandoi = True Then
                For f = LBound(TmpArr, 2) To UBound(TmpArr, 2)
                    SmallValue = TmpArr(i, f)
                    LargeValue = TmpArr(k, f)
                    TmpValue = SmallValue
                    TmpArr(i, f) = LargeValue
                    TmpArr(k, f) = TmpValue
                Next
            End If
        Next
    Next

HCF4068_SortArrAtoZ_Arr2Chieu = TmpArr

End Function
Function HCF4080_DefineColumnEndNo(WS As Worksheet, EndColumn As Integer, RowNo As Integer)
    EndColumn = WS.Cells(RowNo, Columns.Count).End(xlToLeft).Column
End Function

Function Func70IsEmptyArray(anArray As Variant) As Boolean
    Dim i As Integer
    Func70IsEmptyArray = True
    On Error GoTo ExitFunction
    i = UBound(anArray)
    Func70IsEmptyArray = False
ExitFunction:
End Function
Function TBFH120_Call_CreatListLoaiTru(ListLoaiTru() As String)
    ReDim ListLoaiTru(0 To 4)
    ListLoaiTru(0) = ""
    ListLoaiTru(1) = "—L‹xF”¼‹xE“Á‹x"
    ListLoaiTru(2) = "‡ŒvŽžŠÔ"
    ListLoaiTru(3) = "’‹L—“"
    ListLoaiTru(4) = "‹Î‘Ó“à—e"
End Function
Function TBFH115_Call_DefineYearMonthFromYYYYMM(YYYYMM As String, YYYY As String, M As String)
    YYYY = Left(YYYYMM, 4)
    M = Right(YYYYMM, 2)
    M = WorksheetFunction.Text(M, "0")
End Function

Function TBFH116_FilterDataInDataBaseByGroupNo_Year_Month(YYYY As String, M As String, GroupNo As String) As Variant
'Filter Data in Database by GroupNo,TBUF1_Year, TBUF1_Month
'Setting Sheet
    Dim DBWS As Worksheet
    Dim GroupSheet As Worksheet
    Dim DBEndRow As Integer
    Set DBWS = ThisWorkbook.Sheets(DBSheetname)
    Set GroupSheet = ThisWorkbook.Sheets(GroupSheetname)
    Call HCF4079_DefineRowEndNo(DBWS, DBEndRow, 1)
'Define Filter
    Dim FilterRowArr() As Integer
    Dim DByyyy As String
    Dim Dbm As String
    Dim DBGroupNo As String
    For i = 2 To DBEndRow
        DByyyy = DBWS.Cells(i, 1).Value
        Dbm = DBWS.Cells(i, 2).Value
        DBGroupNo = DBWS.Cells(i, 3).Value
        If DByyyy = YYYY And Dbm = M And DBGroupNo = GroupNo Then
            ReDim Preserve FilterRowArr(0 To k)
            FilterRowArr(k) = i
            k = k + 1
        End If
    Next
    If k = 0 Then
        TBFH116_FilterDataInDataBaseByGroupNo_Year_Month = False
        Exit Function
    End If
'Creat FilterDataArr
    Dim FilterDataArr() As String
    ReDim FilterDataArr(0 To k - 1, 0 To 4)
    Dim RowNo As Integer
    Dim DBStaffName As String
    Dim DBProjectCode As String
    Dim DBCustomerName As String
    Dim DBProjectName As String
    Dim DBTotal As String
    For i = LBound(FilterDataArr) To UBound(FilterDataArr)
        RowNo = FilterRowArr(i)
        DBStaffName = DBWS.Cells(RowNo, 6).Value
        DBProjectCode = DBWS.Cells(RowNo, 7).Value
        DBCustomerName = DBWS.Cells(RowNo, 8).Value
        DBProjectName = DBWS.Cells(RowNo, 9).Value
        DBTotal = DBWS.Cells(RowNo, 41).Value
        FilterDataArr(i, 0) = DBStaffName
        FilterDataArr(i, 1) = DBProjectCode
        FilterDataArr(i, 2) = DBCustomerName
        FilterDataArr(i, 3) = DBProjectName
        FilterDataArr(i, 4) = DBTotal
    Next
    TBFH116_FilterDataInDataBaseByGroupNo_Year_Month = FilterDataArr
End Function


Function TBFH117_Call_CreatProjectNameListFromArr(Arr As Variant, ProjectNameList As Variant)
'Get One Column In Arr
    Call TBFH118_Call_GetOneColumnInArr(Arr, ProjectNameList, 3)
'Remove Dup Value in ProjectNameList
    Call TBFH119_Call_RemoveDupValueInArr1Chieu(ProjectNameList)
'Creat ListLoaiTru
    Dim ListLoaiTru() As String
    Call TBFH120_Call_CreatListLoaiTru(ListLoaiTru)
'Remove ListLoaiTru From ProjectNameList
    Call TBFH121_Call_RemoveListLoaiTruFromProjectNameList(ProjectNameList, ListLoaiTru)
End Function

Function TBFH118_Call_GetOneColumnInArr(OriginArr As Variant, ResultArr As Variant, GetColumnNo As Integer)
    ReDim ResultArr(0 To UBound(OriginArr))
    For i = LBound(OriginArr) To UBound(OriginArr)
        ResultArr(i) = OriginArr(i, GetColumnNo)
    Next
End Function


Function TBFH119_Call_RemoveDupValueInArr1Chieu(Arr As Variant)
    Dim AfterRemoveDup() As Variant
    Dim k As Integer
    Dim IsInList As Boolean
    For i = LBound(Arr) To UBound(Arr)
        If k = 0 Then
            ReDim Preserve AfterRemoveDup(0 To k)
            AfterRemoveDup(k) = Arr(i)
            k = k + 1
        Else
            IsInList = HCF4086_IsInArr1Chieu_NumberOrString(AfterRemoveDup, Arr(i))
            If IsInList = False Then
                ReDim Preserve AfterRemoveDup(0 To k)
                AfterRemoveDup(k) = Arr(i)
                k = k + 1
            End If
        End If
    Next
    Arr = AfterRemoveDup
End Function

Function TBFH122_Call_WriteArr2ChieuToRange(Arr As Variant, WS As Worksheet, RowFromNo As Integer, ColumnFromNo As Integer, WriteArrColumnFrom As Integer, WriteArrColumnTo As Integer)
    Dim EachValue As String
    Dim ColumnNo As Integer
    For i = LBound(Arr) To UBound(Arr)
        ColumnNo = ColumnFromNo
        For k = WriteArrColumnFrom To WriteArrColumnTo
            EachValue = Arr(i, k)
            WS.Cells(RowFromNo, ColumnNo).Value = EachValue
            ColumnNo = ColumnNo + 1
        Next
        RowFromNo = RowFromNo + 1
    Next
End Function
Function TBFH123_Call_SetWorksheet()
    Set DBWS = ThisWorkbook.Sheets(DBSheetname)
    Set StaffManagerWS = ThisWorkbook.Sheets(StaffManagerSheetname)
    Set ProjectManagerWS = ThisWorkbook.Sheets(ProjectSheetname)
    Set GroupWS = ThisWorkbook.Sheets(GroupSheetname)
End Function


Function TBFH124_Call_GroupSheet_ClearOldData()
'Clear Group StaffName
    GroupWS.Range("E2:AZ2").ClearContents
'Clear ProjectRange
    GroupWS.Range("A3:AZ49").ClearContents
'Clear Zakken
    GroupWS.Range("D50:AZ59").ClearContents
'Show Hidden row
    GroupWS.Range("A3:A49").EntireRow.Hidden = False
End Function
Function TBFH125_Call_GroupSheet_WriteNote(YYYY As String, M As String)
    Dim GroupNote As String
    GroupNote = YYYY & "”N" & M & "ŒŽ“x‹qæ•ÊŽžŠÔWŒv•\"
    GroupWS.Cells(1, 1).Value = GroupNote
End Function
Function TBFH126_Call_WriteGroupStaffname(GroupNo As String)
'Creat StaffManagerArr
    Call TBFH127_Call_CreatStaffManagerArr
'Filter With GroupNo
    StaffManagerArr = Func000Array03FilterArrWithText(StaffManagerArr, GroupNo, 4)
'Lay chi Staffname
    Dim StaffnameArr As Variant
    StaffnameArr = TBFH128_Lay1CotTrongMang2Chieu(StaffManagerArr, 2)
'Write to GroupSheet
    Call Func000Array02WriteArr1ChieuToRange(StaffnameArr, GroupWS, "E2", "Horizon")
End Function
Function TBFH127_Call_CreatStaffManagerArr()
    Call TBFH123_Call_SetWorksheet
    StaffManagerArr = TBFH102_CrearArrFromRange(StaffManagerWS, "C", "A", "G", 2)
End Function
Function TBFH128_Lay1CotTrongMang2Chieu(MotherArr As Variant, ColumnNo As Integer) As Variant
    Dim SonArr() As Variant
    ReDim SonArr(LBound(MotherArr) To UBound(MotherArr))
    Dim EachValue As Variant
    For i = LBound(MotherArr) To UBound(MotherArr)
        SonArr(i) = MotherArr(i, ColumnNo)
    Next
    TBFH128_Lay1CotTrongMang2Chieu = SonArr
End Function


Function TBFH129_Call_GroupSheet_WriteProjectName(ProjectNameList As Variant)
    Dim PMEndRow As Integer
    Dim IsInList As Boolean
    Dim PMProjectName As String
    Dim WriteRowNo As Integer: WriteRowNo = 3
    Call HCF4079_DefineRowEndNo(ProjectManagerWS, PMEndRow, 3)
    
    For i = 2 To PMEndRow
        PMProjectName = ProjectManagerWS.Cells(i, 3).Value
        IsInList = HCF4086_IsInArr1Chieu_NumberOrString(ProjectNameList, PMProjectName)
        If IsInList = True Then
            GroupWS.Cells(WriteRowNo, 1).Value = ProjectManagerWS.Cells(i, 1).Value
            GroupWS.Cells(WriteRowNo, 2).Value = ProjectManagerWS.Cells(i, 2).Value
            GroupWS.Cells(WriteRowNo, 3).Value = ProjectManagerWS.Cells(i, 3).Value
            WriteRowNo = WriteRowNo + 1
        End If
    Next
End Function
Function TBFH130_Call_GroupSheet_WriteData(WriteData As Variant)
    Dim GEndRow As Integer: GEndRow = 58
    Dim GEndColumn As Integer
    Call HCF4080_DefineColumnEndNo(GroupWS, GEndColumn, 2)
    Dim EachName As String
    Dim EachCustomerName As String
    Dim EachProjectName As String
    Dim EachTime As String
    Dim GetRowNo As Variant
    Dim GetColumnNo As Variant
    Dim WriteRowNo As Integer
    Dim WriteColumnNo As Integer
    For i = LBound(WriteData) To UBound(WriteData)
        EachName = WriteData(i, 0)
        EachCustomerName = WriteData(i, 2)
        EachProjectName = WriteData(i, 3)
        EachTime = WriteData(i, 4)
        GetRowNo = TBFH133_DefineRowNoOfProjectNameInGroupSheet(EachCustomerName, EachProjectName, 3, GEndRow)
        GetColumnNo = TBFH131_DefineColumnNoOfValue(EachName, GroupWS, 2, 5, GEndColumn)
        If VarType(GetRowNo) <> vbBoolean And VarType(GetColumnNo) <> vbBoolean Then
            GroupWS.Cells(GetRowNo, GetColumnNo).Value = EachTime
        End If
    Next
'Sum Row
    Dim RowNo As Integer
    For RowNo = 3 To 58
        Call TBFH134_SumRow(GroupWS, RowNo, 5, GEndColumn, 4)
    Next
'Sum Column
    Dim ColumnNo As Integer
    For ColumnNo = 4 To GEndColumn
        Call TBFH135_SumColumn(GroupWS, ColumnNo, 3, 58, 59)
    Next
End Function

Function TBFH131_DefineColumnNoOfValue(LookupValue As String, WS As Worksheet, RowNo As Integer, ColumnFrom As Integer, ColumnTo As Integer) As Variant
    Dim ResultColumnNo As Integer
    Dim CompareValue As String
    For i = ColumnFrom To ColumnTo
        CompareValue = WS.Cells(RowNo, i).Value
        If CompareValue = LookupValue Then
            TBFH131_DefineColumnNoOfValue = i
            Exit Function
        End If
    Next
    TBFH131_DefineColumnNoOfValue = False
End Function
Function TBFH132_DefineRowNoOfValue(LookupValue As String, WS As Worksheet, ColumnNo As Integer, RowFrom As Integer, RowTo As Integer) As Variant
    Dim ResultRowNo As Integer
    Dim CompareValue As String
    For i = RowFrom To RowTo
        CompareValue = WS.Cells(i, ColumnNo).Value
        If CompareValue = LookupValue Then
            TBFH132_DefineRowNoOfValue = i
            Exit Function
        End If
    Next
    TBFH132_DefineRowNoOfValue = False
End Function
Function TBFH133_DefineRowNoOfProjectNameInGroupSheet(CustomerName As String, ProjectName As String, RowFrom As Integer, RowTo As Integer) As Variant
    Dim ResultRowNo As Integer
    Dim LookupValue As String
    LookupValue = CustomerName & "-" & ProjectName
    Dim CompareValue As String
    For i = RowFrom To RowTo
        CompareValue = GroupWS.Cells(i, 2).Value & "-" & GroupWS.Cells(i, 3).Value
        If CompareValue = LookupValue Then
            TBFH133_DefineRowNoOfProjectNameInGroupSheet = i
            Exit Function
        End If
    Next
    TBFH133_DefineRowNoOfProjectNameInGroupSheet = False
End Function


Function TBFH134_SumRow(WS As Worksheet, RowNo As Integer, ColumnFrom As Integer, ColumnTo As Integer, WriteResultColumn As Integer)
    Dim SumRow As Double
    Dim EachCell As Variant
    For i = ColumnFrom To ColumnTo
        EachCell = WS.Cells(RowNo, i).Value
        If EachCell <> "" Then
            EachCell = CDbl(EachCell)
            SumRow = SumRow + EachCell
        End If
    Next
    If SumRow = 0 Then
        WS.Cells(RowNo, WriteResultColumn).Value = ""
    Else
        WS.Cells(RowNo, WriteResultColumn).Value = SumRow
    End If
End Function
Function TBFH135_SumColumn(WS As Worksheet, ColumnNo As Integer, RowFrom As Integer, RowTo As Integer, WriteResultRow As Integer)
    Dim SumColumn As Double
    Dim EachCell As Variant
    For i = RowFrom To RowTo
        EachCell = WS.Cells(i, ColumnNo).Value
        If EachCell <> "" Then
            EachCell = CDbl(EachCell)
            SumColumn = SumColumn + EachCell
        End If
    Next
    If SumColumn = 0 Then
        WS.Cells(WriteResultRow, ColumnNo).Value = ""
    Else
        WS.Cells(WriteResultRow, ColumnNo).Value = SumColumn
    End If
End Function


Function TBFH136_Call_GroupSheet_HideEmptyRow()
    Dim RowNo As Integer
    Dim CheckValue As String
    For RowNo = 3 To 49
        CheckValue = GroupWS.Cells(RowNo, 4).Value
        If CheckValue = "" Then
            GroupWS.Range("A" & RowNo).EntireRow.Hidden = True
        End If
    Next
End Function


Sub TBS101_CreatGroupSheet()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
'Set worksheet
    Call TBFH123_Call_SetWorksheet
'Get Year, Month From SystemDate
    Dim SystemYear As String: SystemYear = "2021"
    Dim SystemMonth As String: SystemMonth = "4"
'Get Year, Month From DataBase
    Dim DBYearMonth(0 To 11, 0 To 1) As String
    DBYearMonth(0, 0) = "2021":     DBYearMonth(0, 1) = "1"
    DBYearMonth(1, 0) = "2021":     DBYearMonth(1, 1) = "2"
    DBYearMonth(2, 0) = "2021":     DBYearMonth(2, 1) = "3"
    DBYearMonth(3, 0) = "2021":     DBYearMonth(3, 1) = "4"
    DBYearMonth(4, 0) = "2021":     DBYearMonth(4, 1) = "5"
    DBYearMonth(5, 0) = "2021":     DBYearMonth(5, 1) = "6"
    DBYearMonth(6, 0) = "2021":     DBYearMonth(6, 1) = "7"
    DBYearMonth(7, 0) = "2021":     DBYearMonth(7, 1) = "8"
    DBYearMonth(8, 0) = "2021":     DBYearMonth(8, 1) = "9"
    DBYearMonth(9, 0) = "2021":     DBYearMonth(9, 1) = "10"
    DBYearMonth(10, 0) = "2021":    DBYearMonth(10, 1) = "11"
    DBYearMonth(11, 0) = "2021":    DBYearMonth(11, 1) = "12"
    Call TBFH114_Call_CreatYYYYMMArrFromDBYearMonth(DBYearMonth)
'Check SystemYearSystemMonth is in DBYearMonth
    Dim IsInDBYearMonth As Boolean
    IsInDBYearMonth = TBFH113_Check2ValueIsInArr2Chieu_NumberOrString(DBYearMonth, SystemYear, 0, SystemMonth, 1)
    If IsInDBYearMonth = True Then
        SystemMonth = WorksheetFunction.Text(SystemMonth, "00")
        TBUF1_YYYYMM = SystemYear & "." & SystemMonth
    Else
        TBUF1_YYYYMM = YYYYMMArr(UBound(YYYYMMArr))
    End If
'Get StaffName From PCNo
    Dim StaffName As String
    StaffName = "TUAN"
'Get GroupNo From StaffName
    Dim GroupNo As String
    Dim GroupName As String
    GroupNo = TBFH105_GetStaffInformationFromPCNo_StaffID_StaffName(StaffName, "FromName", "GNo")
    If GroupNo = "" Then GroupNo = "1G"
    GroupName = TBFH112_DefineGroupNameFromGroupNo(GroupNo)
'Set TBUF1_GroupNo, TBUF1_Title
    TBUF1_Title = GroupName
    TBUF1_GroupNo = GroupNo
'Get Information From UserForm
    TBUF1_GroupSheet.Show
    If TBUF1_YYYYMM = "" Then
        GoTo GoToExitSub
    Else
        Call TBFH115_Call_DefineYearMonthFromYYYYMM(TBUF1_YYYYMM, TBUF1_Year, TBUF1_Month)
    End If
'Filter Data in Database by GroupNo,TBUF1_Year, TBUF1_Month
    Dim GetFilterData As Variant
    Dim FilterData() As String
    GetFilterData = TBFH116_FilterDataInDataBaseByGroupNo_Year_Month(TBUF1_Year, TBUF1_Month, TBUF1_GroupNo)
    If VarType(GetFilterData) = vbBoolean Then
        MsgBox "Err:No Data"
        GoTo GoToExitSub
    Else
        FilterData = GetFilterData
    End If
'Creat and Sort FilterProjectNameList
    Dim ProjectNameList As Variant
    Call TBFH117_Call_CreatProjectNameListFromArr(FilterData, ProjectNameList)
'Clear Old Data
    Call TBFH124_Call_GroupSheet_ClearOldData
'Write GroupSheetNote
    Call TBFH125_Call_GroupSheet_WriteNote(TBUF1_Year, TBUF1_Month)
'Write Group StaffName
    Call TBFH126_Call_WriteGroupStaffname(TBUF1_GroupNo)
'Write ProjectName
    Call TBFH129_Call_GroupSheet_WriteProjectName(ProjectNameList)
'Write Data
    Call TBFH130_Call_GroupSheet_WriteData(FilterData)
'Hide Empty Row
    Call TBFH136_Call_GroupSheet_HideEmptyRow
GoToExitSub:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    MsgBox "Finish"
End Sub
Function TBFH112_DefineGroupNameFromGroupNo(GroupNo As String) As String
    Select Case GroupNo
        Case "1G"
            TBFH112_DefineGroupNameFromGroupNo = "’†’¬G"
        Case "2G"
            TBFH112_DefineGroupNameFromGroupNo = "ŒÃ‰ÆG"
    End Select
End Function
Function TBFH113_Check2ValueIsInArr2Chieu_NumberOrString(ListArr As Variant, LookupValue1 As Variant, LookupColumnNo1 As Integer, LookupValue2 As Variant, LookupColumnNo2 As Integer) As Boolean
    Dim CompareValue1 As Variant
    Dim CompareValue2 As Variant
    For i = LBound(ListArr) To UBound(ListArr)
        CompareValue1 = ListArr(i, LookupColumnNo1)
        CompareValue2 = ListArr(i, LookupColumnNo2)
        If CompareValue1 = LookupValue1 And CompareValue2 = LookupValue2 Then
            TBFH113_Check2ValueIsInArr2Chieu_NumberOrString = True
            Exit Function
        End If
    Next
End Function
Function TBFH114_Call_CreatYYYYMMArrFromDBYearMonth(DBYearMonth() As String)
    ReDim Preserve YYYYMMArr(0 To UBound(DBYearMonth))
    Dim EachYear As String
    Dim EachMonth As String
    Dim EachYYYYMM As String
    For i = 0 To UBound(DBYearMonth)
        EachYear = DBYearMonth(i, 0)
        EachMonth = DBYearMonth(i, 1)
        EachMonth = WorksheetFunction.Text(EachMonth, "00")
        EachYYYYMM = EachYear & "." & EachMonth
        YYYYMMArr(i) = EachYYYYMM
    Next
End Function
Sub TBS102_SortProjectNameA2Z()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
'Define WS
    Dim PMWS As Worksheet
    Set PMWS = ThisWorkbook.Sheets(ProjectSheetname)
'Creat ProjectNameArr From Range
    Dim ProjectNameArr As Variant
    ProjectNameArr = Func000Array04CrearArrFromRange(PMWS, "C", "A", "Q", 2)
'Creat SortProjectNameArr
    Dim SortProjectNameArr As Variant
    Dim EachGroupNo As String
    Dim EachCustomerName As String
    Dim EachProjectName As String
    Dim EachSort As String
    ReDim SortProjectNameArr(0 To UBound(ProjectNameArr, 1), 0 To UBound(ProjectNameArr, 2) + 1)
    For i = LBound(SortProjectNameArr) To UBound(SortProjectNameArr)
        For k = LBound(ProjectNameArr, 2) To UBound(ProjectNameArr, 2)
            SortProjectNameArr(i, k) = ProjectNameArr(i, k)
        Next
        EachGroupNo = ProjectNameArr(i, 3)
        EachCustomerName = ProjectNameArr(i, 1)
        EachProjectName = ProjectNameArr(i, 2)
        EachSort = EachGroupNo & "-" & EachCustomerName & "-" & EachProjectName
        SortProjectNameArr(i, UBound(SortProjectNameArr, 2)) = EachSort
    Next
'Sort A2Z by GroupNo CustomerName ProjectName
    SortProjectNameArr = HCF4068_SortArrAtoZ_Arr2Chieu(SortProjectNameArr, 17, "String")
'Write Arr to Range
    Call TBFH122_Call_WriteArr2ChieuToRange(SortProjectNameArr, PMWS, 2, 1, 0, 16)
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    MsgBox "Finish"
End Sub

[buianhtuan.cdt]

Private Sub ButtonCancel_Click()
    TBUF1_GroupNo = ""
    TBUF1_YYYYMM = ""
    Unload Me
End Sub
Private Sub ButtonChange_Click()
    TBUF1_GroupNo = CB_GroupNo.Value
    TBUF1_YYYYMM = CB_yyyymm.Value
    Unload Me
End Sub
Private Sub CB_GroupNo_Change()
    TBUF1_GroupNo = CB_GroupNo.Value
    TBUF1_Title = TBFH112_DefineGroupNameFromGroupNo(TBUF1_GroupNo)
    Me.Caption = TBUF1_Title
End Sub
Private Sub UserForm_Initialize()
'Setting List For ComBoBox
    For i = LBound(YYYYMMArr) To UBound(YYYYMMArr)
        CB_yyyymm.AddItem YYYYMMArr(i)
    Next
    CB_GroupNo.AddItem "1G"
    CB_GroupNo.AddItem "2G"
'Set Startup Value
    CB_yyyymm.Value = TBUF1_YYYYMM
    CB_GroupNo = TBUF1_GroupNo
    Me.Caption = TBUF1_Title
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = vbFormControlMenu Then Cancel = True
End Sub