Lai cac tien ich rat hay trong Excel....
Function RangeNameExists(ByVal Nname) As Boolean
' Kiem tra xem ten co ton tai hay khong
' Neu ton tai thi tra ve TRUE
Dim n As Name
RangeNameExists = False
For Each n In ActiveWorkbook.Names
If UCase(n.Name) = UCase(Nname) Then
RangeNameExists = True
Exit Function
End If
Next n
End Function
Function FileExists(ByVal fname) As Boolean
' Return True if the file exists
' fname is the path with filename
Dim x As String
x = Dir(fname)
If x <> "" Then FileExists = True Else FileExists = False
End Function
Function FileNameOnly(ByVal pname) As String
' Return the filename from a path/filename string
Dim i As Integer, length As Integer, temp As String
length = Len(pname)
temp = ""
For i = length To 1 Step -1
If Mid(pname, i, 1) = Application.PathSeparator Then
FileNameOnly = temp
Exit Function
End If
temp = Mid(pname, i, 1) & temp
Next i
FileNameOnly = pname
End Function
Function PathExists(pname) As Boolean
' Return True if the path exists
Dim x As String
On Error Resume Next
x = GetAttr(pname) And 0
If Err = 0 Then PathExists = True Else PathExists = False
End Function
Function SheetExists(ByVal sname) As Boolean
' Return True if sheet exists in the active workbook
Dim x As Object
On Error Resume Next
Set x = ActiveWorkbook.Sheets(sname)
If Err = 0 Then SheetExists = True Else SheetExists = False
End Function
Function WorkbookIsOpen(ByVal wbname) As Boolean
' Return True if the workbook is open
On Error Resume Next
Set x = Workbooks(wbname)
If Err = 0 Then WorkbookIsOpen = True Else WorkbookIsOpen = False
End Function
Function VBAWeekNum(D As Date, FW As Integer) As Integer
VBAWeekNum = CInt(Format(D, "ww", , FW))
End Function
Sub Datten(ByVal TenSheet As String, ByVal TenBang As String, ByVal R1 As Integer, ByVal c1 As Integer, ByVal R2 As Integer, ByVal c2 As Integer)
'Thu tuc nay nham dat ten cho bang du lieu
Dim bCongThuc
On Error Resume Next
bCongThuc = "=" & TenSheet & "!R" & R1 & "C" & c1 & ":" & "R" & R2 & "C" & c2
ActiveWorkbook.Names.Add Name:=TenBang, RefersToR1C1:=bCongThuc
End Sub
Sub SapXep(ByVal TenSheetCanSapXep As String, ByVal R1 As Integer, ByVal c1 As Integer, ByVal R2 As Integer, ByVal c2 As Integer, ByVal cotkhoamot As Integer, ByVal cotkhoahai As Integer)
'Thu tuc nay nham sapxep du lieu theo
'cotkhoamot va cotkhoahai
'Khoi du lieu duoc xac dinh boi khoi R1,C1,R2,C2
On Error Resume Next
Dim tensheethientai As String
Dim btinhtrang As Boolean
tensheethientai = ActiveSheet.Name
Application.ScreenUpdating = False
If Sheets(TenSheetCanSapXep).Visible = False Then
btinhtrang = False
Sheets(TenSheetCanSapXep).Visible = True
Else
btinhtrang = True
End If
Sheets(TenSheetCanSapXep).Select
Range(Cells(R1, c1), Cells(R2, c2)).Select
Selection.Sort Key1:=Cells(R1, cotkhoamot), Order1:=xlAscending, Key2:=Cells(R1, cotkhoahai), Order2:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Cells(R1, c1).Select
Sheets(TenSheetCanSapXep).Visible = btinhtrang
Sheets(tensheethientai).Select
Application.ScreenUpdating = True
End Sub
'Sub MaterialSelector(TenBang As String)
'If Not RangeNameExists(TenBang) Then
' MsgBox "Ten bang khong ton tai ! Xin ban xem lai chuong trinh. ", vbCritical, "Thong bao"
' Exit Sub
'Else
' TableName = TenBang
' frmDataSelector.Show
'End If
'End Sub
'Muc dich doan ma sau nham cho item moi khi nguoi nhap
'go noi dung vao textbox, neu co ma do thi no se cuon len
'de cho thay
'Dim it As ListItem
'On Error Resume Next
' btim = Me.txtitem.Text
' Set it = Me.Lvmavt.FindItem(btim, lvwText, , lvwPartial)
' bindex = it.Index
' Me.Lvmavt.ListItems.Item(bindex).Selected = True
' Me.Lvmavt.ListItems.Item(bindex).EnsureVisible
Public Function TinhTongTDK(bKhoangChung As Range, bChuoiYeuCau As String, _
ByVal bCotTinhTong As Integer, bHamLeftOrRight As Byte, _
ByVal bViTriKhoiDauChoHamMid As Byte)
Dim bRange As Range, bR As Range
Dim i As Integer ' De cho bCot
Dim j As Long ' De cho bHang
Dim bCot As Integer
Dim bHang As Long
Dim bGiatri As String, bSosanh As String
Dim bSoKyTu As Byte
Dim bTong
On Error Resume Next
Set bRange = bKhoangChung
bCot = bRange.Columns.Count
bHang = bRange.Rows.Count
'Truong hop bCotTinhTong <=0 hay >bCot
If bCotTinhTong <= 0 Or bCotTinhTong > bCot Then
TinhTongTDK = "CotTongSai"
Exit Function
End If
'Neu muon dung ham LEFT thi gia tri nay la 1
'Neu muon dung ham RIGHT thi gia tri nay la 2
'Neu muon dung ham MID thi gia tri nay la 3
'Do do neu khac 1 hay 2 hay 3 thi thoat
If bHamLeftOrRight <> 1 And bHamLeftOrRight <> 2 And bHamLeftOrRight <> 3 Then
TinhTongTDK = "HamSai"
Exit Function
End If
bSoKyTu = Len(bChuoiYeuCau)
bChuoiYeuCau = UCase(Trim(bChuoiYeuCau))
For j = 1 To bHang
'Chay qua tung hang
bGiatri = bRange(j, 1)
If bHamLeftOrRight = 1 Then 'i.e Ham LEFT
bSosanh = Left(bGiatri, bSoKyTu)
bSosanh = UCase(Trim(bSosanh))
ElseIf bHamLeftOrRight = 2 Then 'i.e Ham RIGHT
bSosanh = Right(bGiatri, bSoKyTu)
bSosanh = UCase(Trim(bSosanh))
ElseIf bHamLeftOrRight = 3 Then
' Chu y o day ta chua co bay loi cho viec su dung ham MID
bSosanh = Mid(bGiatri, bViTriKhoiDauChoHamMid, bSoKyTu)
bSosanh = UCase(Trim(bSosanh))
End If
If bSosanh = bChuoiYeuCau Then
bTong = bTong + bRange(j, bCotTinhTong)
End If
bSosanh = ""
Next j
TinhTongTDK = bTong
End Function
'Ham tinh tong theo Dieu Kien trong tuan
Public Function TinhTongTDKWeekly(bKhoangChung As Range, bChuoiYeuCau As String, _
ByVal bCotTinhTong1 As Integer, ByVal bCotTinhTong2 As Integer, _
bHamLeftOrRight As Byte)
Dim bRange As Range, bR As Range
Dim i As Integer ' De cho bCot
Dim j As Long ' De cho bHang
Dim bCot As Integer
Dim bHang As Long
Dim bLuuCotTinhTong1 As Integer
Dim bGiatri As String, bSosanh As String
Dim bSoKyTu As Byte
Dim bTong
On Error Resume Next
Set bRange = bKhoangChung
bCot = bRange.Columns.Count
bHang = bRange.Rows.Count
'Truong hop bCotTinhTong1 <=0 hay >bCot
If bCotTinhTong1 <= 0 Or bCotTinhTong1 > bCot Then
TinhTongTDKWeekly = "CotTong1Sai"
Exit Function
End If
If bCotTinhTong2 <= 0 Or bCotTinhTong2 > bCot Then
TinhTongTDKWeekly = "CotTong2Sai"
Exit Function
End If
If bCotTinhTong2 < bCotTinhTong1 Then
TinhTongTDKWeekly = "CotTong1LonHonCotTong2"
Exit Function
End If
'Neu muon dung ham LEFT thi gia tri nay la 1
'Neu muon dung ham RIGHT thi gia tri nay la 2
'Do do neu khac 1 hay 2 thi thoat
If bHamLeftOrRight <> 1 And bHamLeftOrRight <> 2 Then
TinhTongTDKWeekly = "HamLeftRightSai"
Exit Function
End If
bSoKyTu = Len(bChuoiYeuCau)
bChuoiYeuCau = UCase(Trim(bChuoiYeuCau))
bLuuCotTinhTong1 = bCotTinhTong1
For j = 1 To bHang
'Chay qua tung hang
bGiatri = bRange(j, 1)
If bHamLeftOrRight = 1 Then 'i.e Ham LEFT
bSosanh = Left(bGiatri, bSoKyTu)
bSosanh = UCase(Trim(bSosanh))
ElseIf bHamLeftOrRight = 2 Then 'i.e Ham RIGHT
bSosanh = Right(bGiatri, bSoKyTu)
bSosanh = UCase(Trim(bSosanh))
End If
If bSosanh = bChuoiYeuCau Then
Select Case bCotTinhTong2
Case bCotTinhTong1
bTong = bTong + bRange(j, bCotTinhTong1)
Case Is > bCotTinhTong1
Do While bCotTinhTong1 <= bCotTinhTong2
bTong = bTong + bRange(j, bCotTinhTong1)
bCotTinhTong1 = bCotTinhTong1 + 1
Loop
End Select
bCotTinhTong1 = bLuuCotTinhTong1
End If
bSosanh = ""
Next j
TinhTongTDKWeekly = bTong
End Function
levanduyet@yahoo.com