07-04-2021
06:28 AM
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
07-04-2021
06:28 AM
'Setting Sheetname
Public Const DBSheetname As String = "ƒf[ƒ^ƒx[ƒX"
Public Const StaffManagerSheetname As String = "lˆõŠÇ—"
Public Const ProjectSheetname As String = "ˆÄŒŠÇ—"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Function HCF4079_DefineRowEndNo(WS As Worksheet, EndRow As Integer, ColumnNo As Integer)
EndRow = WS.Cells(Rows.Count, ColumnNo).End(xlUp).Row
End Function
Function Func29ConvertColumnLetterToNumber(ColumnLetter As String) As Integer
' Function chuyen ma so cot tu letter sang number
'Convert To Column Number
Dim ColumnNumber As Long
ColumnNumber = Range(ColumnLetter & 1).Column
Func29ConvertColumnLetterToNumber = ColumnNumber
End Function
Function HCF4086_IsInArr2Chieu_NumberOrString(ListArr As Variant, ListColumnNo As Integer, NeedCheckValue As Variant) As Boolean
Dim CompareValue As Variant
For i = LBound(ListArr) To UBound(ListArr)
CompareValue = ListArr(i, ListColumnNo)
If CompareValue = NeedCheckValue Then
HCF4086_IsInArr2Chieu_NumberOrString = True
Exit Function
End If
Next
End Function
Function HCF4060_GetStringMiddle2Delimited(Str As String, Delimited1 As String, Delimited2 As String) As String
Dim Result As String
Dim Delimited1Position As Integer
Dim Delimited2Position As Integer
Delimited1Position = InStr(Str, Delimited1)
Delimited2Position = InStr(Str, Delimited2)
If Delimited1Position * Delimited2Position = 0 Then Exit Function
Result = Mid(Str, Delimited1Position + 1, Delimited2Position - Delimited1Position - 1)
HCF4060_GetStringMiddle2Delimited = Result
End Function
Function HCF4117_VlookupInArr2Dimension_NumberOrString(ListArr As Variant, CheckColumnNo As Integer, ResultColumnNo As Integer, CheckValue As Variant) As Variant
Dim CompareValue As Variant
Dim StrCheckValue As String: StrCheckValue = CStr(CheckValue)
Dim Result As Variant
If HCF4116_IsTwoDimensionalArray(ListArr) = False Then
HCF4117_VlookupInArr2Dimension_NumberOrString = False
Exit Function
End If
For i = LBound(ListArr) To UBound(ListArr)
CompareValue = ListArr(i, CheckColumnNo)
CompareValue = CStr(CompareValue)
If CompareValue = StrCheckValue Then
Result = ListArr(i, ResultColumnNo)
End If
Next
If VarType(Result) = vbEmpty Then Result = False
HCF4117_VlookupInArr2Dimension_NumberOrString = Result
End Function
Function HCF4047_Convert2Integer(InputValue As Variant) As Variant
Dim OutputValue As Variant
On Error Resume Next
OutputValue = CInt(InputValue)
If Err Then
OutputValue = False
Else
OutputValue = CInt(InputValue)
If OutputValue - InputValue <> 0 Then OutputValue = False
End If
HCF4047_Convert2Integer = OutputValue
End Function
Function HCF4048_Convert2Double(InputValue As Variant) As Variant
Dim OutputValue As Variant
On Error Resume Next
OutputValue = CDbl(InputValue)
If Err Then
OutputValue = False
Else
OutputValue = CDbl(InputValue)
End If
HCF4048_Convert2Double = OutputValue
End Function
Function HCF4116_IsTwoDimensionalArray(Arr As Variant) As Boolean
Dim i As Integer
On Error GoTo ExitFunction
i = UBound(Arr, 2)
HCF4116_IsTwoDimensionalArray = True
ExitFunction:
End Function
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Function TBFH100_GetFilePath(FileFilter As String, Title As String, MultiSelectMode As Boolean) As Variant
Dim fnameList As Variant
fnameList = Application.GetOpenFilename(FileFilter, , Title, , MultiSelectMode)
If (vbBoolean = VarType(fnameList)) Then
MsgBox "No files selected"
TBFH100_GetFilePath = False
Else
TBFH100_GetFilePath = fnameList
End If
End Function
Function TBFH102_CrearArrFromRange(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
TBFH102_CrearArrFromRange = Arr
End Function
Function TBFH103_Call_CreatStaffManagerArr(StaffManagerArr As Variant)
Dim StaffWS As Worksheet: Set StaffWS = ThisWorkbook.Sheets(StaffManagerSheetname)
StaffManagerArr = TBFH102_CrearArrFromRange(StaffWS, "C", "A", "G", 2)
End Function
Function TBFH104_DefineMonthFromExcelFilePath(ExcelFilePath As String) As String
Dim MonthValue As String
Dim Delimited1 As String: Delimited1 = "."
Dim Delimited2 As String: Delimited2 = "ŒŽ"
MonthValue = HCF4060_GetStringMiddle2Delimited(ExcelFilePath, Delimited1, Delimited2)
TBFH104_DefineMonthFromExcelFilePath = MonthValue
End Function
Function TBFH105_GetStaffInformationFromPCNo_StaffID_StaffName(LookupValue As String, FromPC_FromID_FromName_Mode As String, PC_ID_SName_GName_GNo_TeamName_TeamNo_Mode As String) As String
'Creat StaffManagerArr
Dim StaffManagerArr As Variant
Call TBFH103_Call_CreatStaffManagerArr(StaffManagerArr)
'Define CheckColumnNo
Dim CheckColumnNo As Integer
Select Case FromPC_FromID_FromName_Mode
Case "FromPC"
CheckColumnNo = 0
Case "FromID"
CheckColumnNo = 1
Case "FromName"
CheckColumnNo = 2
End Select
'Define ResultColumnNo
Dim ResultColumnNo As Integer
Select Case PC_ID_SName_GName_GNo_TeamName_TeamNo_Mode
Case "PC"
ResultColumnNo = 0
Case "ID"
ResultColumnNo = 1
Case "SName"
ResultColumnNo = 2
Case "GName"
ResultColumnNo = 3
Case "GNo"
ResultColumnNo = 4
Case "TeamName"
ResultColumnNo = 5
Case "TeamNo"
ResultColumnNo = 6
Case Else
Exit Function
End Select
'Result
Dim Result As Variant
Result = HCF4117_VlookupInArr2Dimension_NumberOrString(StaffManagerArr, CheckColumnNo, ResultColumnNo, LookupValue)
If VarType(Result) <> vbBoolean Then
TBFH105_GetStaffInformationFromPCNo_StaffID_StaffName = Result
End If
End Function
Function TBFH106_GetProjectInformationFromProjectName(ProjectName As String, ProjectCode_CustomerName_GNo_TNo_1to12_Mode) As String
'Creat ProjectManagerArr
Dim ProjectManagerArr As Variant
Call TBFH107_Call_CreatProjectManagerArr(ProjectManagerArr)
'Define CheckColumnNo
Dim CheckColumnNo As Integer: CheckColumnNo = 2
'Define ResultColumnNo
Dim ResultColumnNo As Integer
Dim Convert2Integer As Variant
Select Case ProjectCode_CustomerName_GNo_TNo_1to12_Mode
Case "ProjectCode"
ResultColumnNo = 0
Case "CustomerName"
ResultColumnNo = 1
Case "GNo"
ResultColumnNo = 3
Case "TNo"
ResultColumnNo = 4
Case Else
Convert2Integer = HCF4047_Convert2Integer(ProjectCode_CustomerName_GNo_TNo_1to12_Mode)
If VarType(Convert2Integer) = vbBoolean Then
Exit Function
Else
If Convert2Integer < 1 Or Convert2Integer > 12 Then
Exit Function
Else
ResultColumnNo = Convert2Integer + 4
End If
End If
End Select
'Result
Dim Result As Variant
Result = HCF4117_VlookupInArr2Dimension_NumberOrString(ProjectManagerArr, CheckColumnNo, ResultColumnNo, ProjectName)
If VarType(Result) <> vbBoolean Then
TBFH106_GetProjectInformationFromProjectName = Result
End If
End Function
Function TBFH107_Call_CreatProjectManagerArr(ProjectManagerArr As Variant)
Dim ProjectWS As Worksheet: Set ProjectWS = ThisWorkbook.Sheets(ProjectSheetname)
ProjectManagerArr = TBFH102_CrearArrFromRange(ProjectWS, "C", "A", "Q", 2)
End Function
Function TBFH108_CheckRangeIsEmpty(WS As Worksheet, RowNo As Integer, ColumnFrom As Integer, ColumnTo As Integer) As Boolean
Dim RangeValue As String
Dim EachValue As String
For i = ColumnFrom To ColumnTo
EachValue = WS.Cells(RowNo, i).Value
RangeValue = RangeValue & EachValue
Next
If RangeValue = "" Then
TBFH108_CheckRangeIsEmpty = True
Else
TBFH108_CheckRangeIsEmpty = False
End If
End Function
Function TBFH109_Call_LockUnLockRange(WS As Worksheet, RowFrom As Integer, RowTo As Integer, ColumnLetterFrom As String, ColumnLetterTo As String, LockMode As Boolean)
Dim LockRange As Range
Set LockRange = WS.Range(ColumnLetterFrom & RowFrom & ":" & ColumnLetterTo & RowTo)
'unlock all
WS.Unprotect
WS.Cells.Locked = False
LockRange.Locked = LockMode
WS.Protect
End Function
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Sub TBS100_GetOldDataIntoDatabase()
Application.ScreenUpdating = False
Application.EnableEvents = False
'Setting
Dim ToWB As Workbook: Set ToWB = ThisWorkbook
Dim ToWS As Worksheet: Set ToWS = ToWB.Sheets(DBSheetname)
Dim StaffWS As Worksheet: Set StaffWS = ToWB.Sheets(StaffManagerSheetname)
'Creat StaffManagerArr
Dim StaffManagerArr As Variant
Call TBFH103_Call_CreatStaffManagerArr(StaffManagerArr)
'Get Files
Dim GetFiles As Variant
Dim FileFilter As String: FileFilter = "Excel Files (*.xls),*.xls"
Dim Title As String: Title = "Choose Excel files"
Dim MultiSelectMode As Boolean: MultiSelectMode = True
GetFiles = TBFH100_GetFilePath(FileFilter, Title, True)
If VarType(GetFiles) = vbBoolean Then GoTo GotoExitSub
Dim FromWSData() As Variant
Dim FromWSDataRowNo As Integer
For i = LBound(GetFiles) To UBound(GetFiles)
'Open File
Dim FromWSEachRowData(1 To 40) As String
Dim FromWBPath As String: FromWBPath = GetFiles(i)
Dim FromWB As Workbook: Set FromWB = Workbooks.Open(FromWBPath, , True)
Dim FromWS As Worksheet
Dim FromSheetname As String
Dim FromEndRow As Integer
Dim IsStaffName As Boolean
Dim MonthValue As String: MonthValue = TBFH104_DefineMonthFromExcelFilePath(FromWBPath): FromWSEachRowData(1) = MonthValue
Dim GroupValue As String
Dim TeamValue As String
Dim StaffID As String
Dim StaffName As String
Dim ProjectCode As String
Dim CustomerName As String
Dim ProjectName As String
Dim FromWSEndRow As Integer
For Each FromWS In FromWB.Sheets
FromSheetname = FromWS.Name
'Check FromSheetname is Staff Name
IsStaffName = HCF4086_IsInArr2Chieu_NumberOrString(StaffManagerArr, 2, FromSheetname)
If IsStaffName = False Then GoTo GoToExitLoop
StaffName = FromSheetname
GroupValue = TBFH105_GetStaffInformationFromPCNo_StaffID_StaffName(StaffName, "FromName", "GNo")
TeamValue = TBFH105_GetStaffInformationFromPCNo_StaffID_StaffName(StaffName, "FromName", "TeamNo")
StaffID = TBFH105_GetStaffInformationFromPCNo_StaffID_StaffName(StaffName, "FromName", "ID")
FromWSEachRowData(2) = GroupValue
FromWSEachRowData(3) = TeamValue
FromWSEachRowData(4) = StaffID
FromWSEachRowData(5) = StaffName
'Define FromWSEndRow
Call HCF4079_DefineRowEndNo(FromWS, FromWSEndRow, 34)
If FromWSEndRow <= 3 Then GoTo GoToExitLoop
FromWSEndRow = FromWSEndRow - 2
'Define EachSheetData
Dim CheckRowValue As String
For f = 4 To FromWSEndRow
CheckRowValue = FromWS.Cells(f, 34).Value
If CheckRowValue <> "" Then
ProjectName = FromWS.Cells(f, 2).Value
ProjectCode = TBFH106_GetProjectInformationFromProjectName(ProjectName, "ProjectCode")
CustomerName = TBFH106_GetProjectInformationFromProjectName(ProjectName, "CustomerName")
If CustomerName = "" Then CustomerName = FromWS.Cells(f, 1).Value
FromWSEachRowData(6) = ProjectCode
FromWSEachRowData(7) = CustomerName
FromWSEachRowData(8) = ProjectName
For k = 3 To 34
FromWSEachRowData(k + 6) = FromWS.Cells(f, k).Value
Next
ReDim Preserve FromWSData(0 To FromWSDataRowNo)
FromWSData(FromWSDataRowNo) = FromWSEachRowData
FromWSDataRowNo = FromWSDataRowNo + 1
End If
Next
'Write ChuuKiRan
Dim ChuuKiRanIsEmpty As Boolean
Dim ChuuKiRanRowNo As Integer: ChuuKiRanRowNo = FromWSEndRow + 4
ChuuKiRanIsEmpty = TBFH108_CheckRangeIsEmpty(FromWS, ChuuKiRanRowNo, 3, 34)
If ChuuKiRanIsEmpty = False Then
FromWSEachRowData(6) = ""
FromWSEachRowData(7) = ""
FromWSEachRowData(8) = FromWS.Cells(ChuuKiRanRowNo, 2).Value
For k = 3 To 34
FromWSEachRowData(k + 6) = FromWS.Cells(ChuuKiRanRowNo, k).Value
Next
ReDim Preserve FromWSData(0 To FromWSDataRowNo)
FromWSData(FromWSDataRowNo) = FromWSEachRowData
FromWSDataRowNo = FromWSDataRowNo + 1
End If
'Write KinTai
Dim KinTaiRowNo As Integer: KinTaiRowNo = FromWSEndRow + 5
FromWSEachRowData(6) = ""
FromWSEachRowData(7) = ""
FromWSEachRowData(8) = FromWS.Cells(KinTaiRowNo, 2).Value
For k = 3 To 34
FromWSEachRowData(k + 6) = FromWS.Cells(KinTaiRowNo, k).Value
Next
ReDim Preserve FromWSData(0 To FromWSDataRowNo)
FromWSData(FromWSDataRowNo) = FromWSEachRowData
FromWSDataRowNo = FromWSDataRowNo + 1
GoToExitLoop:
Next
FromWB.Close False
Next
'Write FromWSData to DataBase
If FromWSDataRowNo = 0 Then GoTo GotoExitSub
'Define WriteRowFrom
Dim WriteRowFrom As Integer
Call HCF4079_DefineRowEndNo(ToWS, WriteRowFrom, 1)
WriteRowFrom = WriteRowFrom + 1
Dim EachRowData As Variant
Dim EachValue As String
For i = LBound(FromWSData) To UBound(FromWSData)
EachRowData = FromWSData(i)
For k = LBound(EachRowData) To UBound(EachRowData)
EachValue = EachRowData(k)
If EachValue <> "" Then
ToWS.Cells(WriteRowFrom, k) = EachRowData(k)
End If
Next
WriteRowFrom = WriteRowFrom + 1
Next
GotoExitSub:
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox "Finish"
End Sub