Thủ thuật Excel

  • Thread starter HyperVN
  • Ngày gửi
Q

quocnghia

Guest
24/3/04
64
0
6
Các bạn có ai có tài liệu về Microsoft Query for Excell không ? Nó hay lắm đấy!
 
Khóa học Quản trị dòng tiền
anhoanh

anhoanh

Guest
25/3/04
105
1
0
45
Đà Nẵng
To: WhoamI
Nếu bác nhập ô a1=02/2004, ta có thể dùng hàm weekday cùng với hàm eomonth để tìm được kết quả mà bạn mong muốn.
=+IF(WEEKDAY(EOMONTH(A1,0),1)=1,EOMONTH(A1,0)-2,IF(WEEKDAY(EOMONTH(A1,0),1)=7,EOMONTH(A1,0)-1,EOMONTH(A1,0)))
 
Sửa lần cuối:
W

WhoamI

Cao cấp
anhoanh nói:
To: WhoamI
Nếu bác nhập ô a1=02/2004, ta có thể dùng hàm weekday cùng với hàm eomonth để tìm được kết quả mà bạn mong muốn.
=+IF(WEEKDAY(EOMONTH(A1,0),1)=1,EOMONTH(A1,0)-2,IF(WEEKDAY(EOMONTH(A1,0),1)=7,EOMONTH(A1,0)-1,EOMONTH(A1,0)))
Hàm eomonth là hàm trả về ngày cuối tháng đúng không nhỉ?
thế mà lúc W tìm mãi trong fx mà không có! Thế là biết thêm 2 hàm thật hay: eomonth và Weekday! Em xin cảm ơn các bác!
 
H

handung107

Cao cấp
28/8/04
576
15
0
VN
www.giaiphapexcel.com
Các công thức đều rất hay, nhưng WhoamI à, 30/11/2004 la 2 ngày thứ ba mà, công thức của mình không sai
 
W

WhoamI

Cao cấp
handung107 nói:
Các công thức đều rất hay, nhưng WhoamI à, 30/11/2004 la 2 ngày thứ ba mà, công thức của mình không sai
Dạ đúng rồi ạ! em mới test thử do chưa hiểu ngay được công thức.
To anhoanh mình đã thử hàm eomonth nhưng không được vì trong Functions của excel 2000 không có.
 
Sửa lần cuối:
anhoanh

anhoanh

Guest
25/3/04
105
1
0
45
Đà Nẵng
Bác vào Tools ->Add-ins và chọn analyis toolpak và analyis toolpak -vba
Và mọi thứ sẽ ok.
Chúc Bác thành công !
 
Sửa lần cuối:
B

Bình_OverAC

Over Abnormal / Crazy
14/5/04
846
10
18
42
Nha Trang
Có bác nào sử dụng office XP không?? Nếu có các bác có thể tạo ra công thức mãng như các bác WhoamI, handung107... đang bàn bằng cách Data--> conditional sum
 
N

NguyenVanVuong

Guest
2/10/04
9
0
1
44
Tp Ho Chi Minh
Neu nhu viec lay gia tri lon nhat trong mang gia tri ta su dung ham Max, Tuy nhien, neu minh muon lay gia tri lon thu nhi trong mang gia tri thi su dung cong thuc hay ham nao.
Ngoai ra, cac ban nao thao Exel chi giup minh cach lap cong thuc chuyen so tien bang so sang so tien bang chu.
Mong cac ban giup minh voi nhe!
Cam on cac ban nhieu!
 
H

handung107

Cao cấp
28/8/04
576
15
0
VN
www.giaiphapexcel.com
Hàm chuyển số thành chữ đã đề cập rất nhiều trên Webketoan rồi. Muốn lấy giá trị lớn thứ n trong mảng ta dùng hàm LARGE(mang,n). Bạn muốn biết thêm nhiều về sử dụng các hàm hãy vào Insert/Function, bạn chọn tên hàm rồi click vào Help on this Function, sẽ có những hướng dẫn rất cụ thể và chi tiết
 
Q

QAA

Guest
To Nguyenvanvuong: de chuyen so tien thanh chu bac phai dung macro. em gui cho bac cai nay bac xai thu roi cho y kien nha:
Function dichchu(amt)
'Dim amt As Integer
If amt = 0 Then
resp = "khoâng ñoàng"
Else
If Abs(amt) > 999999999999.99 Then
resp = " Soá quaù lôùn"
Else
If amt < 0 Then
resp = "tröø"
Else
resp = ""
End If
Tien = Format(Abs(amt), "###########0.00")
Tien = Right(Space(12) + Tien, 15)
doc = " traêm möôi tyû" + " traêm möôi trieäu" + " traêm möôi nghìn" + " traêm möôi ñoàng" + " traêm möôi xu"
dem = "moät hai ba boán naêm saùu baûy taùm chín"

For i = 1 To 5
nhom = Mid(Tien, i * 3 - 2, 3)
If nhom <> Space(3) Then
Select Case nhom
Case "000"
If i = 4 Then
chu = "ñoàng "
Else
chu = Space(0)
End If
Case ".00"
chu = "chaün "
Case Else
so1 = Left(nhom, 1)
so2 = Mid(nhom, 2, 1)
so3 = Right(nhom, 1)
chu = ""
For j = 1 To 3
dich = ""
s = Val(Mid(nhom, j, 1))
If s > 0 Then
dich = Trim(Mid(dem, s * 5 - 4, 5)) + Space(1) + Trim(Mid(doc, (i - 1) * 18 + j * 6 - 5, 6)) + Space(1)
End If
Select Case j
Case 2 And s = 1
dich = "möôøi "
Case 3 And s = 0 And nhom <> " 0"
dich = Trim(Mid(doc, (i - 1) * 18 + j * 6 - 5, 6)) + " "
Case 3 And s = 5 And so2 <> " " And so2 <> "0"
dich = "1" + Mid(dich, 2)
Case 2 And s = 0 And so3 <> "0"
If (so1 >= "1" And so1 <= "9") Or (so1 = "0" And i = 4) Then
dich = "leû "
End If
End Select
chu = chu + dich
Next j
End Select
vitri = InStr(1, chu, " möôi moát", 1)
If vitri > 0 Then
Mid(chu, vitri, 9) = " möôi moát"
End If
resp = resp + chu
End If
Next i
End If
End If
dichchu = UCase(Left(resp, 1)) + Mid(resp, 2)
End Function
 
B

Bình_OverAC

Over Abnormal / Crazy
14/5/04
846
10
18
42
Nha Trang
Chào QAA,
Cậu tham gia vào hội những người sử dụng Macro khi nào vậy?
Đoạn code của cậu tớ thấy quen lắm.
Tớ thấy hình như đã gặp trong các add-in mà các mem upload lên một lần rồi. (tớ xem đoạn code thì hình như nó khác một chút nhưng cách thức thì cũng ý như vậy). Hơn nữa cậu cho người ta đoạn code mà không hướng dẩn cụ thể thì cũng khó mà người ta có thể sử dụng.
Khi nào rảnh tớ sẽ upload lên cả một add-in có các hàm cơ bản gồm dịch số sang chử bằng 2 thứ tiếng anh và Việt, theo kiểu USD và VND.
Hay là khi nào rảnh cậu ghé qua nhà tớ, tớ sẽ cho cậu một số tác phẩm của tớ, và các bản chỉnh sửa tác phẩm của người khác cho cậu sài chơi và cùng bàn luận về Macro nhé, với lại cậu còn nợ tớ một chầu cafe đấy nhé.
 
N

NguyenVanVuong

Guest
2/10/04
9
0
1
44
Tp Ho Chi Minh
Cam on Bac
Chuong trinh cua BAC chay duoc
Nhung no khong dung
VIDU: 100000
no ra chu: Mot tram ghin tra...
Dai khai No khong doc chinh xac so ra chu
Mong BAC chi giup ho cho
Xin cam on
 
W

wildhair

Guest
Các bác giúp em với:
Trên Excel, sau 1 hồi nhân chia tính toán, được số: 34.15 em đem nhân với 15.700 cho kết quả là: 536.116
Nhưng cũng với các phép tính đấy, em dùng máy tính bấm thì được kết quả là; 536.155
Làm thế nào để excel trả về kết quả như bấm máy tính bi giờ các bác? Bà kế toán trưởng chỗ em đang hành em về vấn đề này đây này.
 
B

Bình_OverAC

Over Abnormal / Crazy
14/5/04
846
10
18
42
Nha Trang
Có thể kết quả tính toán của bạn không đúng khi cho ra số 34.15 Theo mình thì nó đã nhỏ hơn con số này, khoảng 34.14752 Bạn nên dùng hàm round với số 34.15 của bạn cụ thể
= round("giá trị cần làm tròn", 2)
2 là số chữ số sau dấu phân chia thập phân.
Nếu số này là 0 có nghĩa là làm tròn đến hàm đơn vị
Nếu số này là số âm: ví dụ - 3 thi sẽ làm tròn tới hàng ngàn
round(157.460,-3)=157.000
 
H

holdyou20002000

Guest
Hinh nhu Macro la mot chuc nang rat hay trong excel dac biet trong ke toan. co ai hieu ro ve Macro va cach ung dung cua no nu the nao khong ?minh chi hieu Macro la "ghi lai nhung thao tac minh lam" va no se "tu dong" lam lai y chang khi minh su dung no.(co the cho minh mot VD cu the duoc khong?)
 
levanduyet

levanduyet

Welcome
16/10/04
537
19
18
HCM
my.opera.com
Minh muon upload len mot vai module minh da suu tam va chinh sua nhung o dien dan chi cho so luong tu it qua !!! Sau day la Ham QuickSort minh suu tam va sua lai....va con nhieu nua nhung khong the dua len het.
Nhan day xin cac ban xem Ham Cham Cong cua minh tren trang web PC World VN.
Xin cac ban cho minh y kien nha.
levanduyet@yahoo.com
'Copyright 2000 Alan Beban
Public Function QuickSort(VA_array, Optional V_Low1, Optional V_high1)
'I have adjust some code in this function
'Before it is the procedure not the function
On Error Resume Next
'Dimension variables
Dim V_Low2, V_high2, V_loop As Integer
Dim V_val1, V_val2
Dim V_Middle
Dim VA_array_Temp
Dim bCot As Integer, bHang As Long
Dim i As Integer
'
'If first time, get the size of the array to sort
If IsMissing(V_Low1) Then
V_Low1 = LBound(VA_array, 1)
End If
If IsMissing(V_high1) Then
V_high1 = UBound(VA_array, 1)
End If
'Cal the fields and records
bCot = UBound(VA_array, 2)
bHang = V_high1
'Set new extremes to old extremes
V_Low2 = V_Low1
V_high2 = V_high1
'Get value of array item in middle of new extremes
V_Middle = (V_Low1 + V_high1) / 2
V_val1 = VA_array(V_Middle, 1)

'Loop for all the items in the array between the extremes
Do While (V_Low2 <= V_high2)
'Find the first item that is greater than the mid-point item
'Sap xep dua vao Cot dau tien cua mang
Do While (VA_array(V_Low2, 1) < V_val1 And V_Low2 < V_high1)
V_Low2 = V_Low2 + 1
Loop
'Find the last item that is less than the mid-point item
Do While (VA_array(V_high2, 1) > V_val1 And V_high2 > V_Low1)
V_high2 = V_high2 - 1
Loop
'If the new 'greater' item comes before the new 'less' item, swap them
If (V_Low2 <= V_high2) Then
'=========================================
'Hang nay cua Tac gia, nham luu lai cac gia tri
ReDim VA_array_Temp(1 To bCot)
'Nham luu gia tri Chinh
For i = 1 To bCot
VA_array_Temp(i) = VA_array(V_Low2, i)
Next
'=========================================
'VA_array(V_Low2, 1) = VA_array(V_high2, 1)
'Toi dua them vao nham gan cac gia tri khac cua mang
For i = 1 To bCot
VA_array(V_Low2, i) = VA_array(V_high2, i)
Next
'=========================================
'VA_array(V_high2, 1) = VA_array(V_Low2, 1)
'Toi dua them vao nham gan cac gia tri khac cua mang
For i = 1 To bCot
VA_array(V_high2, i) = VA_array_Temp(i)
Next
'Advance the pointers to the next item
V_Low2 = V_Low2 + 1
V_high2 = V_high2 - 1
End If
Loop
'Iterate to sort the lower half of the extremes
If (V_high2 > V_Low1) Then Call QuickSort(VA_array, V_Low1, V_high2)
'Iterate to sort the upper half of the extremes
If (V_Low2 < V_high1) Then Call QuickSort(VA_array, V_Low2, V_high1)
QuickSort = VA_array
End Function
 
levanduyet

levanduyet

Welcome
16/10/04
537
19
18
HCM
my.opera.com
Day la cac Ham va Thu tuc de cac ban thao tac voi Recordset rat hay....
Toi lay tu bai hoc lop Visual basic nang cao cua Dai Hoc Khoa Hoc Tu Nhien...
Cac ban xem the nao? Toi van dung thay rat hay...
levanduyet@yahoo.com
....Dien dan khong cho upload nhieu...tiec that...xin cac mod xem lai...
Public Sub Dchuyen(Frm As UserForm, Rst As ADODB.Recordset, Index As Integer)
If Not Capnhat(Frm, Rst) Then Exit Sub
With Rst
Select Case Index
Case 0
.MoveFirst
Case 1
.MovePrevious
If .BOF Then .MoveFirst
Case 2
.MoveNext
If .EOF Then .MoveLast
Case 3
.MoveLast
End Select
End With
End Sub
Public Sub CheDC(Frm As UserForm, Rst As ADODB.Recordset)
Dim i%
For i = 0 To 3
Frm.Cmddc(i).Enabled = False
Next
If Rst.BOF Or Rst.EOF Then Exit Sub
If Rst.EditMode = adEditAdd Then Exit Sub
With Frm.Cmddc
.Item(0).Enabled = Rst.AbsolutePosition <> 1
.Item(1).Enabled = .Item(0).Enabled
.Item(2).Enabled = Rst.AbsolutePosition <> Rst.RecordCount
.Item(3).Enabled = .Item(2).Enabled
End With
End Sub
Public Sub Chnang(Frm As UserForm, Rst As ADODB.Recordset, Index As Integer)
On Error GoTo loi
Dim bmk
If (Index = 0 And Rst.EditMode <> adEditAdd) Or Index > 3 Then
If Not Capnhat(Frm, Rst) Then Exit Sub
End If
Select Case Index
Case 0
If Rst.EditMode = adEditNone Then
Rst.AddNew
End If
Case 1
Dim Ctrl As Control, Biloi As Boolean
Set Ctrl = XdinhCtrl(Frm, Rst, Biloi)
If Biloi Then
Dim vung() As String, i%
vung = Frm.Napvung()
For i = 0 To UBound(vung)
If LCase(Ctrl.DataField) = LCase(vung(i, 1)) Then Exit For
Next
Thongbao vung(i, 0) & " bò nhaäp lieäu sai kieåu", 16, "Xin chu y"
Ctrl.SetFocus
Exit Sub
End If

Rst.Update
Case 2
If Rst.EditMode = adEditAdd Then
KTKieu Frm, Rst
Else
Phuchoi Frm, Rst
End If
Rst.CancelUpdate
Rst.Move 0
Case 3
.........
 
levanduyet

levanduyet

Welcome
16/10/04
537
19
18
HCM
my.opera.com
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
 
levanduyet

levanduyet

Welcome
16/10/04
537
19
18
HCM
my.opera.com
Lai cac tien ich rat hay, toi thuong xu dung trong lap trinh VBA...
Xin cac ban cho y kien...
levanduyet@yahoo.com

'*********************
'MOT SO HAM VE HE THONG
'*********************
Option Explicit

Private Declare Function RegOpenKeyA Lib "ADVAPI32.DLL" (ByVal hKey As Long, ByVal sSubkey As String, ByRef hkeyResult As Long) As Long
Private Declare Function RegCreateKeyA Lib "ADVAPI32.DLL" (ByVal hKey As Long, ByVal sSubkey As String, ByRef hkeyResult As Long) As Long
Private Declare Function RegQueryValueExA Lib "ADVAPI32.DLL" (ByVal hKey As Long, ByVal sValueName As String, ByVal dwReserved As Long, ByRef lValueType As Long, ByVal sValue As String, ByRef lResultLen As Long) As Long
Private Declare Function RegCloseKey Lib "ADVAPI32.DLL" (ByVal hKey As Long) As Long
Private Declare Function GetSystemMetrics32 Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
Private Declare Function GetWindowsDirectoryA Lib "KERNEL32" (ByVal P$, ByVal s%) As Integer
' Khai bao nham mo mot File giong nhu khi ban Double Click vao File
' khi muon mo mot File trong Window explorer
#If Win32 Then
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long

[HASHTAG]#Else[/HASHTAG]
Declare Function ShellExecute Lib "SHELL" (ByVal hWnd%, _
ByVal lpszOp$, ByVal lpszFile$, ByVal lpszParams$, _
ByVal lpszDir$, ByVal fsShowCmd%) As Integer

Declare Function GetDesktopWindow Lib "USER" () As Integer
[HASHTAG]#End[/HASHTAG] If
' Bien nay se mo tap tin, xem o dang toan bo man hinh
Private Const SW_SHOWNORMAL = 3
' Ham nay nham mo mot File
' Chi viec goi ten File do
Function STARTDOC(ByVal DocName As String) As Long
Dim Scr_hDC As Long
Scr_hDC = GetDesktopWindow()
STARTDOC = ShellExecute(Scr_hDC, "Open", _
DocName, "", "C:\", SW_SHOWNORMAL)
End Function
' Ham nay nham tra ve Chuoi, the hien Thu muc
' Excel duoc install vao may
Function EXCELDIR() As String
' Returns the directory in which Excel is installed
EXCELDIR = Application.Path
End Function
' Ham nay nham doc gia tri tu Registry cua Window
Function GETREGISTRY(Key, SubKey, ByVal ValueName As String)
'\ Reads a value from the Windows Registry
Dim hKey As Long, lValueType As Long, sResult As String, lResultLen As Long
Dim x, TheKey As Long
TheKey = -99
Select Case UCase(Key)
Case "HKEY_CLASSES_ROOT": TheKey = &H80000000
Case "HKEY_CURRENT_USER": TheKey = &H80000001
Case "HKEY_LOCAL_MACHINE": TheKey = &H80000002
Case "HKEY_USERS": TheKey = &H80000003
Case "HKEY_CURRENT_CONFIG": TheKey = &H80000004
Case "HKEY_DYN_DATA": TheKey = &H80000005
End Select
If TheKey = -99 Then
GETREGISTRY = "Not Found"
Exit Function
End If
If RegOpenKeyA(TheKey, SubKey, hKey) <> 0 Then x = RegCreateKeyA(TheKey, SubKey, hKey)
sResult = Space(100)
lResultLen = 100
If RegQueryValueExA(hKey, ValueName, 0, lValueType, sResult, lResultLen) <> 0 Then
GETREGISTRY = "Not Found"
Else
GETREGISTRY = Left(sResult, lResultLen - 1)
End If
RegCloseKey hKey
End Function

Function WRITEREGISTRY(ByVal Key As String, ByVal Path As String, ByVal entry As String, ByVal value As String)
Dim hKey As Long, lValueType As Long, sResult As String, lResultLen As Long, TheKey, x
TheKey = &H80000001
If RegOpenKeyA(TheKey, Path, hKey) <> 0 Then x = RegCreateKeyA(TheKey, Path, hKey)
x = RegSetValueExA(hKey, entry, 0, 1, value, Len(value) + 1)
If x = 0 Then WRITEREGISTRY = True Else WRITEREGISTRY = False
End Function
' Ham nay xac dinh Width cua man hinh
Function SCREENWIDTH()
SCREENWIDTH = GetSystemMetrics32(0)
End Function
' Ham nay xac dinh Height cua man hinh
Function SCREENHEIGHT()
SCREENHEIGHT = GetSystemMetrics32(1)
End Function

' Ham nay xac dinh so Sheet trong Workbook hien tai
Function SHEETCOUNT()
SHEETCOUNT = Application.Parent.Parent.Worksheets.Count
End Function
' Ham nay tra ve ten cua WorkSheet
' Neu khong co cho gia tri sheetnum thi ham se tra ve ten cua ung dung
'Function SHEETNAME(Optional sheetnum As Integer) As String
'
' If sheetnum = 0 Then
' SHEETNAME = Application.Parent.Name
' Else
' SHEETNAME = Application.Parent.Parent.Sheets(sheetnum).Name
' End If
'End Function
Function USER()
' Returns the name of the current user
USER = Application.UserName
End Function

Function WINDOWSDIR() As String
' Returns the Windows directory by calling a Windows API function
Dim WinPath As String
WinPath = String(145, Chr(0))
WINDOWSDIR = Left(WinPath, GetWindowsDirectoryA(WinPath, Len(WinPath)))
End Function

Function WINDOWSVERSION()
' Returns the Windows version number
WINDOWSVERSION = Right(Application.OperatingSystem, 4)
End Function
 

Xem nhiều

Webketoan Zalo OA