topic Re: How make dimensions horizontal and vertical in VBA code? in VBA Forum

How make dimensions horizontal and vertical in VBA code?

ladimirabdala — Sat, 30 Jan 2010 13:14:20 GMT

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

Re: How make dimensions horizontal and vertical in VBA code?

ladimirabdala — Sat, 30 Jan 2010 15:53:53 GMT

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

Re: How make dimensions horizontal and vertical in VBA code?

zsolti_sdd — Sat, 04 Jul 2015 09:15:35 GMT

for what is point 3 ???

Re: How make dimensions horizontal and vertical in VBA code?

Alfred.NESWADBA — Sat, 04 Jul 2015 10:34:11 GMT

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 -

Re: How make dimensions horizontal and vertical in VBA code?

buianhtuan.cdt — Sun, 11 Jul 2021 13:42:54 GMT

'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

Re: How make dimensions horizontal and vertical in VBA code?

buianhtuan.cdt — Mon, 12 Jul 2021 11:49:59 GMT

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‹xF”¼‹xE“Á‹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

Re: How make dimensions horizontal and vertical in VBA code?

buianhtuan.cdt — Mon, 12 Jul 2021 22:10:02 GMT

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