Thủ thuật Excel

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

levanduyet

Welcome
16/10/04
537
19
18
HCM
my.opera.com
SỬ DỤNG VBA ĐỂ CẬP NHẬT CODE TRONG MODULE CỦA BẠN.
Excel 97 hay các phiên bản sau này có khả năng cập nhật (update) mã (code) trong module. Nói cách khác, bạn có thể viết một đoạn code VBA để tạo ra một đoạn code VBA khác.
Tham khảo đến một module
Bước đầu tiên là tạo một đối tượng (object) tham chiếu đến code của module mà bạn dự định sửa chửa. Thuộc tính (property) CodeModule trả về một đối tượng đại diện cho code nằm đằng sau VB component. Trong đoạn ví dụ dưới đây, MyCodeMod là một biến đối tượng đại diện cho code trong Module1 của active workbook.

Set MyCodeMod = ActiveWorkbook.VBProject.VBComponents("Module1").CodeModule
Đếm số dòng code trong module
Bạn có thể sử dụng thuộc tính CountOfLines để xác định có bao nhiêu dòng code tồn tại trong module (kể cả các dòng trống). Ví dụ sau đây thông báo cho bạn số dòng code trong module:

MsgBox MyCodeMod.CountOfLines

Đoạn code bạn tham khảo đến trong module
Bạn có thể sử dụng thuộc tính Lines(dòng bắt đầu, số dòng) trả về biến kiểu String để lấy đọan mã từ dòng bắt đầu đến số dòng bạn cần lấy. Ví dụ trong module1 của tôi có đoạn mã như sau:

Dòng 1
Dòng 2
Dòng 3
Dòng 4
Dòng 5
Dòng 6


Sub testing()
Dim mycodemod
Set mycodemod = ActiveWorkbook.VBProject.VBComponents("Module1").codemodule
MsgBox mycodemod.countoflines
MsgBox mycodemod.Lines(1, 4)
End Sub




Xoá một đoạn code trong module

Bạn có thể sử dụng phương thức (method) Deletelines(dòng bắt đầu, số dòng) để xoá một dòng hay nhiều dòng code. Đọan code sau sẽ xoá dòng 4 trong module1.

Mycodemod.Deletelines 4
Thêm một dòng trong module
Bạn có thể sử dụng phương thức (method) Insertlines(vị trí dòng bạn muốn thêm vào, đoạn code bạn cần thêm vào). Ví dụ sau để thêm tại dòng số 2 của code trong module1 chuổi Dim MyString As String

Mycodemod.Insertlines(2, "Dim MyString As String")
Thay thế một dòng code trong module
Bạn có thể sử dụng phương thức (method) Replaceline(dòng cần thay thế, đoạn code thay thế) . Ví dụ sau để thay thế dòng số 2 của code trong module1 chuổi Dim MyNumber As Integer.

Mycodemod.Replaceline(2, "Dim MyNumber As Integer")
Đặt nội dung của một File vào trong module
Bạn có thể sử dụng phương thức (method) AddFromFile(đường dẫn đến File tham chiếu). Ví dụ sau thay thế đoạn code trong File book2.frm có đường dẫn là c:\Code Files\book2.frm vào trong module1

Mycodemod.AddFromFile "c:\Code Files\book2.frm"
Với việc sử dụng một số thuộc tính, phương thức trên tôi tin rằng bạn có thể làm cho các đoạn code trong module của bạn linh động hơn.



Sau đây là một số hàm bạn cần khi thao tác.

Thêm một thủ tục vào một module
Bạn có thể thêm trực tiếp đoạn mã vào một module mà không cần phải dùng một file text riêng. Thủ tục sau đây sẽ làm điều đó:

Sub InsertProcedureCode(ByVal wb As Workbook, ByVal InsertToModuleName As String)

Dim VBCM As CodeModule
Dim InsertLineIndex As Long
On Error Resume Next
Set VBCM = wb.VBProject.VBComponents(InsertToModuleName).CodeModule
If Not VBCM Is Nothing Then
With VBCM
InsertLineIndex = .CountOfLines + 1
' customize the next lines depending on the code you want to insert
.InsertLines InsertLineIndex, "Sub NewSubName()" & Chr(13)
InsertLineIndex = InsertLineIndex + 1
.InsertLines InsertLineIndex, " Msgbox ""Hello World!"",vbInformation,""Message Box Title""" & Chr(13)
InsertLineIndex = InsertLineIndex + 1
.InsertLines InsertLineIndex, "End Sub" & Chr(13)
' no need for more customizing
End With
Set VBCM = Nothing
End If
On Error GoTo 0
End Sub

Ví dụ:
InsertProcedureCode Workbooks("WorkBookName.xls"), "Module1"
Thêm đoạn mã vào một module từ một file
Nếu bạn không muốn thêm vào một module hoàn chỉnh, bạn có thể thêm vào chỉ một vài thủ tục bị thiếu vào module bằng cách sử dụng thủ tục dưới đây. Thủ tục này thêm dữ liệu chứa trong file text vào module hiện tại:

Sub ImportModuleCode(ByVal wb As Workbook, ByVal ModuleName As String, ByVal ImportFromFile As String)
' Nhap ma vao ModuleName trong wb tu mot textfile ten ImportFromFile
Dim VBCM As CodeModule
If Dir(ImportFromFile) = "" Then Exit Sub
On Error Resume Next
Set VBCM = wb.VBProject.VBComponents(ModuleName).CodeModule
If Not VBCM Is Nothing Then
VBCM.AddFromFile ImportFromFile
Set VBCM = Nothing
End If
On Error GoTo 0
End Sub

Ví dụ:
ImportModuleCode ActiveWorkbook, "TestModule", "C:\FolderName\NewCode.txt"
Kiểm tra xem một VBProject có được bảo vệ hay không
Với hàm dưới đây, bạn có thể kiểm tra xem một VBProject có được bảo vệ không trước khi bạn cố gắng sửa chữa nó:

Function ProtectedVBProject(ByVal wb As Workbook) As Boolean
'Tra ve TRUE neu VB project trong tai lieu hien tai duoc bao ve
Dim VBC As Integer
VBC = -1
On Error Resume Next
VBC = wb.VBProject.VBComponents.Count
On Error GoTo 0
If VBC = -1 Then
ProtectedVBProject = True
Else
ProtectedVBProject = False
End If
End Function

Ví dụ:
If ProtectedVBProject(ActiveWorkbook) Then Exit Sub


Tạo một module mới
Với thủ tục dưới đây bạn có thể tạo một module mới trong một workbook:

Sub CreateNewModule(ByVal wb As Workbook, ByVal ModuleTypeIndex As Integer, ByVal NewModuleName As String)
' Tao mot module moi kieu ModuleTypeIndex (1=standard module, 2=userform, 3=class module) trong wb
' Dat lai ten module moi sang NewModuleName (neu co the)
Dim VBC As VBComponent, mti As Integer
Set VBC = Nothing
mti = 0
Select Case ModuleTypeIndex
Case 1: mti = vbext_ct_StdModule ' standard module
Case 2: mti = vbext_ct_MSForm ' userform
Case 3: mti = vbext_ct_ClassModule ' class module
End Select
If mti <> 0 Then
On Error Resume Next
Set VBC = wb.VBProject.VBComponents.Add(mti)
If Not VBC Is Nothing Then
If NewModuleName <> "" Then
VBC.Name = NewModuleName
End If
End If
On Error GoTo 0
Set VBC = Nothing
End If
End Sub

Ví dụ:
CreateNewModule ActiveWorkbook, 1, "TestModule"
Xoá một module
Khi bạn muốn xoá một module, bạn có thể dùng thủ tục dưới đây:

Sub DeleteVBComponent(ByVal wb As Workbook, ByVal CompName As String)
' Xoa vbcomponent ten CompName tu wb
Application.DisplayAlerts = False
On Error Resume Next ' Neu co loi thi lam tiep cau lenh ke tiep
wb.VBProject.VBComponents.Remove wb.VBProject.VBComponents(CompName) ' Xoa component
On Error GoTo 0
Application.DisplayAlerts = True
End Sub
Ví dụ:
DeleteVBComponent ActiveWorkbook, "TestModule"
Xoá một thủ tục ra khỏi một module
Với thủ tục dưới đây, bạn có thể xoá thủ tục ra khỏi một module:

Sub DeleteProcedureCode(ByVal wb As Workbook, ByVal DeleteFromModuleName As String, ByVal ProcedureName As String)
' Xoa thu tuc ProcedureName tu DeleteFromModuleName trong wb
Dim VBCM As CodeModule, ProcStartLine As Long, ProcLineCount As Long
On Error Resume Next
Set VBCM = wb.VBProject.VBComponents(DeleteFromModuleName).CodeModule
If Not VBCM Is Nothing Then
' xem xet thu tuc co ton tai trong codemodule hay khong
ProcStartLine = 0
ProcStartLine = VBCM.ProcStartLine(ProcedureName, vbext_pk_Proc)
If ProcStartLine > 0 Then ' prosedyren finnes, slett den
ProcLineCount = VBCM.ProcCountLines(ProcedureName, vbext_pk_Proc)
VBCM.DeleteLines ProcStartLine, ProcLineCount
End If
Set VBCM = Nothing
End If
On Error GoTo 0
End Sub
 
Khóa học Quản trị dòng tiền
levanduyet

levanduyet

Welcome
16/10/04
537
19
18
HCM
my.opera.com
(Tiep theo)
Ví dụ:
DeleteProcedureCode Workbooks("WorkBookName.xls"), "Module1", "ProcedureName"
Thêm vào một module mới từ một file
Với thủ tục dưới đây, bạn có thể dễ dàng thêm vào một module mới trong một workbook (Với chú ý file *.bas phải được tạo trước)

Sub InsertVBComponent(ByVal wb As Workbook, ByVal CompFileName As String)
' Them CompFileName vao nhu la mot new component trong wb
If Dir(CompFileName) <> "" Then ' source file ton tai
On Error Resume Next ' Neu co loi thi thi hanh lenh tiep theo, i.e neu project duoc bao ve
wb.VBProject.VBComponents.Import CompFileName ' inserts component from file
On Error GoTo 0
End If
Set wb = Nothing
End Sub

Ví dụ:
InsertVBComponent ActiveWorkbook, "C:\FolderName\Filename.bas"
Phục hồi lại cửa sổ VBE về vị trí mặc định (default positions)
Nếu bạn gặp vấn đề với việc định vị các cửa sổ VBE, bạn có thể phục hồi lại vị trí của chúng bằng cách sửa trong Registry.

Chú ý! bạn nên sao lưu Registry trước khi bạn sửa nó. Nếu bạn đang sử dụng Windows NT, bạn cũng nên cập nhật Emergency Repair Disk (ERD).
Nếu bạn không biết về Registry thì xin bạn đừng làm điều này.

Đóng Excel và VBE.

Vào hộp thoại Run, gõ vào RegEdit, Enter.

Di chuyển đến HKEY_USERS\.Default\Software\Microsoft\VBA\Office.

Đặt tên (hay xoá) giá trị Dock , Excel sẽ tạo lại nó khi chạy lần sau.

Đóng RegEdit.

Mở Excel và VBE, các cửa sổ bây giờ trở về vị trí mặc định của nó.



Lê Văn Duyệt.

Mọi ý kiến góp ý xin bạn liên lạc về:

levanduyet@yahoo.com
 
levanduyet

levanduyet

Welcome
16/10/04
537
19
18
HCM
my.opera.com
Các ví dụ cơ bản về các thao tác với các tập tin và thư mục trong VBA cho Excel

Làm thế nào để lấy được ổ đĩa và tên của thư mục hiện tại:

MsgBox "O dia va ten thu muc hien tai la " & CurDir
Làm thế nào để thay đổi ổ đĩa hiện tại:

ChDrive "F"


Làm thế nào để thay đổi thư mục hiện hành:

ChDir "F:\My Documents\Private"


Làm thế nào để xác định một File tồn tại trong một thư mục:

If Dir("F:\My Documents\My Workbook.xls") <> "" Then
' Chuỗi rỗng sẽ được trả về nếu File không tồn tại


Làm thế nào để xoá một tập tin:

Kill "F:\My Documents\My Workbook.xls"
Nếu bạn không chỉ ra ổ đĩa, Excel sử dụng ổ đĩa hiện hành. Nếu bạn không chỉ ra thư mục, Excel sẽ sử dụng thư mục hiện hành.

Làm thế nào để tạo thư mục mới:

MkDir "NewPrivateFolder" ' Tạo một thư mục mới trong thư mục hiện hành
MkDir "F:\My Documents\NewPrivateFolder"
' Tạo một thư mục mới trong thư mục F:\My Documents
Làm thế nào để xoá một thư mục (thư mục phải là rổng):

RmDir "NewPrivateFolder"
' Xóa thư mục con NewPrivateFolder trong thư mục hiện hành
RmDir "F:\My Documents\NewPrivateFolder"
' Xóa thư mục con NewPrivateFolder trong thư mục F:\My Documents
Làm thế nào để sao chép một tập tin (Tập tin phải là tập tin đóng):

FileCopy "OrgWorkBook.xls", "CopyWorkBook.xls"
' Sao chép OrgWorkBook.xls sang CopyWorkBook.xls trong thư mục hiện hành
FileCopy "OrgWorkBook.xls", "F:\My Documents\CopyWorkBook.xls"
' Sao chép OrgWorkBook.xls từ thư mục hiện hành sang F:\My Documents\CopyWorkBook.xls
Làm thế nào để di chuyển một tập tin (Tập tin phải là tập tin đóng):

OldFilePath = "C:\OldFolder\Filename.xls" ' đường dẫn tập tin gốc
NewFilePath = "C:\NewFolder\Filename.xls" ' đường dẫn tập tin mới
Name OldFilePath As NewFilePath ' di chuyển tập tin
Xác định một file đang được sử dụng (hay mở)
Với hàm dưới đây bạn có thể biết được tập tin có đang được các chương trình khác sử dụng hay không. Hàm sẽ trả về True nếu không thể truy cập hoàn toàn (full access).

Function FileAlreadyOpen(FullFileName As String) As Boolean
' Tra ve True neu tap tin FullFileName dang duoc cac chuong trinh khac su dung hay mo
Dim f As Integer
f = FreeFile
On Error Resume Next
Open FullFileName For Binary Access Read Write Lock Read Write As #f
Close #f
' Neu co loi thi co nghia tai lieu dang duoc mo
If Err.Number <> 0 Then
FileAlreadyOpen = True
Err.Clear
'MsgBox "Error #" & Str(Err.Number) & " - " & Err.Description
Else
FileAlreadyOpen = False
End If
On Error GoTo 0
End Function
Tên tập tin và tên thư mục
Hàm dưới đây có thể được sử dụng để trả về tên tập tin hay tên thư mục từ tên đầy đủ (full file name):

Function FileOrFolderName(InputString As String, ReturnFileName As Boolean) As String
Dim i As Integer, FolderName As String, FileName As String
i = 0
While InStr(i + 1, InputString, Application.PathSeparator) > 0
i = InStr(i + 1, InputString, Application.PathSeparator)
Wend
If i = 0 Then
FolderName = CurDir
Else
FolderName = Left(InputString, i - 1)
End If
FileName = Right(InputString, Len(InputString) - i)
If ReturnFileName Then
FileOrFolderName = FileName
Else
FileOrFolderName = FolderName
End If
End Function
Thủ tục sau kiểm tra hàm FileOrFolderName
Sub TestFileOrFolderName()
MsgBox FileOrFolderName(ThisWorkbook.FullName, False), , "Ten thu muc cua Workbook nay la:"
MsgBox FileOrFolderName(ThisWorkbook.FullName, True), , "Ten tap tin cua Workbook nay la:"
End Sub
Liệt kê các tập tin trong thư mục áp dụng cho Office 97 hay các phiên bản sau đó
Trong Office 97 hay các phiên bản sau đó, bạn dễ dàng lấy danh sách các tập tin và thư mục con trong một thư mục:

Function CreateFileList(FileFilter As String, IncludeSubFolder As Boolean) As Variant
' tra ve ten t?p tin day du cho cac files thoa dieu kien trong thu muc hien hanh
Dim FileList() As String, FileCount As Long
CreateFileList = ""
Erase FileList
If FileFilter = "" Then FileFilter = "*.*" ' tat ca cac tap tin
With Application.FileSearch
.NewSearch
.LookIn = CurDir
.FileName = FileFilter
.SearchSubFolders = IncludeSubFolder
.FileType = msoFileTypeAllFiles
If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) = 0 Then Exit Function
ReDim FileList(.FoundFiles.Count)
For FileCount = 1 To .FoundFiles.Count
FileList(FileCount) = .FoundFiles(FileCount)
Next FileCount
.FileType = msoFileTypeExcelWorkbooks
End With
CreateFileList = FileList
Erase FileList
End Function
Ví dụ sau kiểm tra hàm CreateFileList ở trên:
Sub TestCreateFileList()
Dim FileNamesList As Variant, i As Integer
'ChDir "C:\My Documents" ' Chuyen thu muc hien hanh
FileNamesList = CreateFileList("*.*", False) ' Thuc hien tim kiem File bao gom cac thu muc con
' Dua ra ket qua
Range("A:A").ClearContents
For i = 1 To UBound(FileNamesList)
Cells(i + 1, 1).Formula = FileNamesList(i)
Next i
End Sub
Chọn các tập tin
Thủ tục dưới đây cho thấy làm cách nào để cho ngừơi dùng chọn một tập tin nào đó:

Sub OpenOneFile()
Dim fn As Variant
fn = Application.GetOpenFilename("Excel-files,*.xls", 1, "Chon mot tap tin de mo", , False)
If TypeName(fn) = "Boolean" Then Exit Sub ' nguoi dung khong chon tap tin nao ca
Debug.Print "Selected file: " & fn
Workbooks.Open fn
End Sub
Thủ tục dưới đây cho thấy làm cách nào để cho người dùng chọn nhiều tập tin:
Sub OpenMultipleFiles()
Dim fn As Variant, f As Integer
fn = Application.GetOpenFilename("Excel-files,*.xls", 1, "Chon mot hay nhieu tap tin de mo", , True)
If TypeName(fn) = "Boolean" Then Exit Sub
For f = 1 To UBound(fn)
Debug.Print "Selected file #" & f & ": " & fn(f)
Workbooks.Open fn(f)
MsgBox ActiveWorkbook.Name, , "Ten Workbook hien hanh la:"
ActiveWorkbook.Close False ' Dong workbook hien hanh ma khong luu
Next f
End Sub
Thủ tục dưới đây cho thấy làm cách nào để cho ngừơi dùng chọn thư mục và tên tập tin để lưu lại:

Sub SaveOneFile()
Dim fn As Variant
fn = Application.GetSaveAsFilename("Tentaptin.xls", "Excel files,*.xls", 1, "Ban hay chon thu muc va ten tap tin")
If TypeName(fn) = "Boolean" Then Exit Sub
ActiveWorkbook.SaveAs fn
End Sub
Chọn thư mục
Với sự trợ giúp của một cặp hàm API, bạn có thể thể hiện hộp thoại để ngừơi dùng chọn thư mục:

Private Type BROWSEINFO ' Duoc su dung boi ham GetFolderName
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetFolderName(Msg As String) As String
' Tra ve ten cua thu muc ma nguoi dung chon
Dim bInfo As BROWSEINFO, path As String, r As Long, X As Long, pos As Integer
bInfo.pidlRoot = 0& ' Root folder = Desktop
If IsMissing(Msg) Then
bInfo.lpszTitle = "Chon mot thu muc." ' Title cua hop thoai
Else
bInfo.lpszTitle = Msg ' Title cua hop thoai
End If
bInfo.ulFlags = &H1 ' Kieu cua thu muc tra ve (Type of directory to return)
X = SHBrowseForFolder(bInfo) ' The hien hop thoai
' Phan tich ket qua (Parse the result)
path = Space$(512)
r = SHGetPathFromIDList(ByVal X, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetFolderName = Left(path, pos - 1)
Else
GetFolderName = ""
End If
End Function
Ví dụ sau kiểm tra hàm trên.

Sub TestGetFolderName()
Dim FolderName As String
FolderName = GetFolderName("Select a folder")
If FolderName = "" Then
MsgBox "Ban da khong chon thu muc nao ca."
Else
MsgBox "Ban da chon thu muc: " & FolderName
End If
End Sub
Hy vọng rằng với các hàm trên sẽ giúp ích cho các bạn một phần nào trong việc lập trình VBA cho Excel. Nếu các bạn muốn tìm hiểu kỹ các bạn có thể tham khảo bài viết của Nguyễn Lan Anh trên Website Lê Hoàn.

Lược dịch và sưu tầm. Mọi góp ý xin gởi về: levanduyet@yahoo.com

Lê Văn Duyệt.
 
levanduyet

levanduyet

Welcome
16/10/04
537
19
18
HCM
my.opera.com
VỊ TRÍ FORM (Phần I)
VỊ TRÍ CỦA FORM
Vâng, thưa các bạn có những lúc các bạn muốn form người dùng hiện ra tại một vị trí, hay một ô nào bạn muốn. Thế thì làm sao chúng ta có thể làm được vậy? Chúng ta hãy cùng đọc bài FormPosition trên trang Web cpearson.
Đầu tiên chúng ta hãy chép module vào file Excel của chúng ta:
modFormPositioner module
Option Explicit
Option Compare Text

''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Module Name: modFormPositioner
' Date: 22-Sept-2002
' Author: Chip Pearson, www.cpearson.com, chip@cpearson.com
' Copyright: (c) Copyright 2002, Charles H Pearson.
'
' Description: Calculates to position to display
' a userform relative to a cell.
'
' Usage:
' Declare a variable of type Positions:
' Dim PS As Positions
' Call the PositionForm function, passing it the following
' parameters:
' WhatForm The userform object
'
' AnchorRange The cell relative to which the form
' should be displayed.
'
' NudgeRight Optional: Number of points to nudge the
' for to the right. This is useful with
' bordered range. Typically, this should
' be 0, but may be positive or negative.
'
' NudgeDown Optional: Number of points to nudge the
' for downward. This is useful with
' bordered range. Typically, this should
' be 0, but may be positive or negative.
'
' HorizOrientation: Optional: One of the following values:
' cstFhpNull = Left of screen
' cstFhpAppCenter = Center of Excel screen
' cstFhpAuto = Automatic (recommended and default)
'
' cstFhpFormLeftCellLeft = left edge of form at left edge of cell
' cstFhpFormLeftCellRight = left edge of form at right edge of cell
' cstFhpFormLeftCellCenter = left edge of form at center of cell
'
' cstFhpFormRightCellLeft = right edge of form at left edge of cell
' cstFhpFormRightCellRight = right edge of form at right edge of cell
' cstFhpFormRightCellCenter = right edge of form at center of cell
'
' cstFhpFormCenterCellLeft = center of form at left edge of cell
' cstFhpFormCenterCellRight = center of form at right edge of cell
' cstFhpFormCenterCellCenter = center of form at center of cell
'
' VertOrientation Optional: One of the following values:
'
' cstFvpNull = Top of screen
' cstFvpAppCenter = Center of Excel screen
' cstFvpAuto = Automatic (recommended and default)
'
' cstFvpFormTopCellTop = top edge of form at top edge of cell
' cstFvpFormTopCellBottom = top edge of form at bottom edge of cell
' cstFvpFormTopCellCenter = top edge of form at center of cell
'
' cstFvpFormBottomCellTop = bottom edge of form at top of edge of cell
' cstFvpFormBottomCellBottom = bottom edge of form at bottom edge of cell
' cstFvpFormBottomCellCenter = bottom edge of form at center of cell
'
' cstFvpFormCenterCellTop = center of form at top of cell
' cstFvpFormCenterCellBottom = center of form at bottom of cell
' cstFvpFormCenterCellCenter = center of form at center of cell
'
' For example:
' PS = PositionForm (UserForm1,Range("C12"),0,0,cstFvpAuto,cstFhpAuto)
'
' Then, position the form using the values from PS:
' UserForm1.Top = PS.FrmTop
' UserForm1.Left = PS.FrmLeft
' Finally, show the form:
' UserForm1.Show vbModal
'
' In summary, the code would look like
'
' Dim PS As Positions
' PS = PositionForm (UserForm1,ActiveCell,0,0,cstFvpAuto,cstFhpAuto)
' UserForm1.Top = PS.FrmTop
' UserForm1.Left = PS.FrmLeft
' UserForm1.Show vbModal
'
'
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''

''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Type: Positions
'
' We store everything in a structure so that we can easily
' pass things around from on procedure to another. Otherwise,
' we'd quickly run out of stack space passing to the
' optimazation procedures.
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Type Positions

FrmTop As Single ' Userform
FrmLeft As Single
FrmHeight As Single
FrmWidth As Single

RngTop As Single ' Passed in cell
RngLeft As Single
RngWidth As Single
RngHeight As Single


AppTop As Single 'Application
AppLeft As Single
AppWidth As Single
AppHeight As Single

WinTop As Single ' Window
WinLeft As Single
WinWidth As Single
WinHeight As Single

Cell1Top As Single ' 1st cell in visible range
Cell1Left As Single
Cell1Width As Single
Cell1Height As Single

LastCellTop As Single ' last visible cell in window
LastCellLeft As Single
LastCellWidth As Single
LastCellHeight As Single

BaseLeft As Single ' the are the screen based coordinates for the upper left corner
BaseTop As Single ' of cell.

VComp As Single ' compensations for displayed object (toolbars, headers, etc)
HComp As Single

NudgeDown As Single ' allow the user to nudge the positioning by a few pixels.
NudgeRight As Single

#If VBA6 Then
OrientationH As cstFormHorizontalPosition
OrientationV As cstFormVerticalPosition
[HASHTAG]#Else[/HASHTAG]
OrientationH As Long
OrientationV As Long
[HASHTAG]#End[/HASHTAG] If

End Type
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' End TYPE
''''''''''''''''''''''''''''''''''''''''''''''''''''''''

#If VBA6 Then
Public Enum cstFormHorizontalPosition
cstFhpNull = -2 ' X = 0, left of screen
cstFhpAppCenter = -1
cstFhpAuto = 0

cstFhpFormLeftCellLeft
cstFhpFormLeftCellRight
cstFhpFormLeftCellCenter

cstFhpFormRightCellLeft
cstFhpFormRightCellRight
cstFhpFormRightCellCenter

cstFhpFormCenterCellLeft
cstFhpFormCenterCellRight
cstFhpFormCenterCellCenter
End Enum

Public Enum cstFormVerticalPosition
cstFvpNull = -2 ' Y = 0, top of screen
cstFvpAppCenter = -1
cstFvpAuto = 0

cstFvpFormTopCellTop
cstFvpFormTopCellBottom
cstFvpFormTopCellCenter

cstFvpFormBottomCellTop
cstFvpFormBottomCellBottom
cstFvpFormBottomCellCenter

cstFvpFormCenterCellTop
cstFvpFormCenterCellBottom
cstFvpFormCenterCellCenter
End Enum

[HASHTAG]#Else[/HASHTAG]

Public Const cstFhpNull As Long = -2 ' X = 0, left of screen
Public Const cstFhpAppCenter As Long = -1
Public Const cstFhpAuto As Long = 0

Public Const cstFhpFormLeftCellLeft As Long = 1
Public Const cstFhpFormLeftCellRight As Long = 2
Public Const cstFhpFormLeftCellCenter As Long = 3

Public Const cstFhpFormRightCellLeft As Long = 4
Public Const cstFhpFormRightCellRight As Long = 5
Public Const cstFhpFormRightCellCenter As Long = 6

Public Const cstFhpFormCenterCellLeft As Long = 7
Public Const cstFhpFormCenterCellRight As Long = 8
Public Const cstFhpFormCenterCellCenter As Long = 9

Public Const cstFvpNull As Long = -2 ' Y = 0, top of screen
Public Const cstFvpAppCenter As Long = -1
Public Const cstFvpAuto As Long = 0

Public Const cstFvpFormTopCellTop As Long = 1
Public Const cstFvpFormTopCellBottom As Long = 2
Public Const cstFvpFormTopCellCenter As Long = 3

Public Const cstFvpFormBottomCellTop As Long = 4
Public Const cstFvpFormBottomCellBottom As Long = 5
Public Const cstFvpFormBottomCellCenter As Long = 6

Public Const cstFvpFormCenterCellTop As Long = 7
Public Const cstFvpFormCenterCellBottom As Long = 8
Public Const cstFvpFormCenterCellCenter As Long = 9

[HASHTAG]#End[/HASHTAG] If
 
levanduyet

levanduyet

Welcome
16/10/04
537
19
18
HCM
my.opera.com
VỊ TRÍ FORM (Phần II)
Public Const cColHeaderHeight As Single = 9
Public Const cRowHeaderWidth As Single = 20
Public Const cDefaultWindowFrameHeight As Single = 26
Public Const cDefaultWindowFrameWidth As Single = 6
Public Const cDefaultCmdBarHeight = 26
Private Const cLeftBump = 5
Private Const cRightBump = 0
Private Const cUpBump = 0
Private Const cDownBump = 0

#If VBA6 Then
Function PositionForm(WhatForm As Object, AnchorRange As Range, _
Optional NudgeRight As Single = 0, Optional NudgeDown As Single = 0, _
Optional ByVal HorizOrientation As cstFormHorizontalPosition = cstFhpAuto, _
Optional ByVal VertOrientation As cstFormVerticalPosition = cstFvpAuto) As Positions

[HASHTAG]#Else[/HASHTAG]
Function PositionForm(WhatForm As Object, AnchorRange As Range, _
Optional NudgeRight As Single = 0, Optional NudgeDown As Single = 0, _
Optional ByVal HorizOrientation As Long = cstFhpAuto, _
Optional ByVal VertOrientation As Long = cstFvpAuto) As Positions

[HASHTAG]#End[/HASHTAG] If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' PositionForm
'
' The positions the form on the screen according to the specified
' parameters. It returns a Position structure.
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim CmdBar As Office.CommandBar
Dim DefaultCmdBarHeight As Single

Dim VCmdArr(0 To 20) As Single ' hold our command bar widths -- assume fewer that 20 rows
Dim HCmdArr(0 To 20) As Single ' of command bars.

Dim HasVisibleWindow As Boolean
Dim Win As Window
Dim PS As Positions

Dim Ndx As Long

Dim ColHeaderHeight As Single: ColHeaderHeight = cColHeaderHeight
Dim RowHeaderWidth As Single: RowHeaderWidth = cRowHeaderWidth
Dim DefaultWindowFrameHeight As Single: DefaultWindowFrameHeight = cDefaultWindowFrameHeight
Dim DefaultWindowFrameWidth As Single: DefaultWindowFrameWidth = cDefaultWindowFrameWidth

PS.OrientationH = HorizOrientation
PS.OrientationV = VertOrientation
PS.NudgeRight = NudgeRight
PS.NudgeDown = NudgeDown
'
' If Excel is minimized, set to 0,0 and get out. The caller should NOT be
' displaying a form when XL is minimized.
'
If Application.WindowState = xlMinimized Then
WhatForm.Top = 0
WhatForm.Left = 0
PS.FrmTop = 0
PS.FrmWidth = 0
PS.OrientationH = cstFhpNull
PS.OrientationV = cstFvpNull
Exit Function
End If
'
' If the AnchorRange is not within the visible range of the activewindow,
' then force the form to be displayed as AppCenter.
'
If Application.Intersect(AnchorRange, ActiveWindow.VisibleRange) Is Nothing Then
HorizOrientation = cstFhpAppCenter
VertOrientation = cstFvpAppCenter
End If
'
' If there are no windows visible, force AppCenter.
'
For Each Win In Application.Windows
If Win.Visible = True Then
HasVisibleWindow = True
Exit For
End If
Next Win

If HasVisibleWindow = False Then
HorizOrientation = cstFhpAppCenter
VertOrientation = cstFvpAppCenter
End If
'
' get our object coordinates.
'
With Application
PS.AppTop = .Top
PS.AppLeft = .Left
PS.AppWidth = .Width
PS.AppHeight = .Height
End With

With Application.ActiveWindow
PS.WinTop = .Top
PS.WinLeft = .Left
PS.WinWidth = .Width
PS.WinHeight = .Height
With .VisibleRange.Cells(1, 1)
PS.Cell1Top = .Top
PS.Cell1Left = .Left
PS.Cell1Height = .Height
PS.Cell1Width = .Width
End With
With .VisibleRange
PS.LastCellTop = .Cells(.Cells.Count).Top
PS.LastCellLeft = .Cells(.Cells.Count).Left
PS.LastCellWidth = .Cells(.Cells.Count).Width
PS.LastCellHeight = .Cells(.Cells.Count).Height
End With
End With
With AnchorRange
PS.RngTop = .Top
PS.RngLeft = .Left
PS.RngWidth = .Width
PS.RngHeight = .Height
End With

PS.FrmHeight = WhatForm.Height
PS.FrmWidth = WhatForm.Width
'
' we'll assume that the application's caption bar and the formula
' bar are the same height as the menu bar. If we can't figure that out, use 26 as a default.
'
If Application.CommandBars.ActiveMenuBar.Visible = True Then
DefaultCmdBarHeight = Application.CommandBars.ActiveMenuBar.Height
Else
DefaultCmdBarHeight = cDefaultCmdBarHeight
End If
'
' We have to have a compenstating factor for command bars. Load an array
' with the heights of visible command bars. The index into the array is
' the RowIndex of the command bar, so we won't "double dip" if two or more
' command bars occupy the same row.
'
For Each CmdBar In Application.CommandBars
With CmdBar
If (.Visible = True) And (.Position = msoBarTop) Or (.Position = msoBarMenuBar) Then
If .RowIndex > 0 Then
VCmdArr(.RowIndex) = .Height
End If
End If
If (.Visible = True) And (.Position = msoBarLeft) Then
If .RowIndex > 0 Then
HCmdArr(.RowIndex) = .Width
End If
End If
End With
Next CmdBar
'
' Now, add up the values in the array so that we can
' get the compensation neeed for toolbars on the
' top and left side of the screen.
'
For Ndx = LBound(VCmdArr) To UBound(VCmdArr)
PS.VComp = PS.VComp + VCmdArr(Ndx)
Next Ndx

For Ndx = LBound(HCmdArr) To UBound(HCmdArr)
PS.HComp = PS.HComp + HCmdArr(Ndx)
Next Ndx

'''''''''''''''''''''''''''''''''''''''''''''''''''
' VERTICAL COMPENSATION
'''''''''''''''''''''''''''''''''''''''''''''''''''
If Application.DisplayFullScreen = True Then
'''''''''''''''''''''''''''''''''''''''''''''''
' FULL SCREEN VERTICAL COMPENSATION - OK
'''''''''''''''''''''''''''''''''''''''''''''''
PS.VComp = DefaultCmdBarHeight
'
' compensate for the rown and column headers
'
If ActiveWindow.DisplayHeadings = True Then
PS.VComp = PS.VComp + ColHeaderHeight
Else
PS.VComp = PS.VComp - (0.666667 * ColHeaderHeight)
End If

' no formula bar compensation is required since the
' formula bar is not displayed in full-screen mode.

Else
'''''''''''''''''''''''''''''''''''''''''''''''
' NORMAL SCREEN VERTICAL COMPENSATION
'''''''''''''''''''''''''''''''''''''''''''''''
'
' compensate for the rown and column headers
'
If ActiveWindow.DisplayHeadings = True Then
PS.VComp = PS.VComp + ColHeaderHeight
Else
PS.VComp = PS.VComp - (0.666667 * ColHeaderHeight)
End If
'
' compenstate for formula bar
'
If Application.DisplayFormulaBar = True Then
PS.VComp = PS.VComp + DefaultCmdBarHeight
Else
PS.VComp = PS.VComp + (ColHeaderHeight * 1.5)
End If
''''''''''''''''''''''''''''''''''''''''''''''''
End If
 
levanduyet

levanduyet

Welcome
16/10/04
537
19
18
HCM
my.opera.com
VỊ TRÍ FORM (Phần III)
'''''''''''''''''''''''''''''''''''''''''''''''''''
' HORIZONTAL COMPENSATION
'''''''''''''''''''''''''''''''''''''''''''''''''''
If Application.DisplayFullScreen = True Then
'''''''''''''''''''''''''''''''''''''''''''''''
' FULL SCREEN HORIZONTAL COMPENSATION
'''''''''''''''''''''''''''''''''''''''''''''''
PS.HComp = 0
'''''''''''''''''''''''''''''''''''''''''''''''
'Else
' do nothing -- HComp is already correct.
End If
'
' compensate for the row and column headers
'
If ActiveWindow.DisplayHeadings = True Then
PS.HComp = PS.HComp + RowHeaderWidth
Else
PS.HComp = PS.HComp
End If


'''''''''''''''''''''''''''''''''''''''''''''''
' Now, adjust for the window
'''''''''''''''''''''''''''''''''''''''''''''''
Select Case Application.ActiveWindow.WindowState

Case xlMaximized
'
' in the case of a maximized window, the action Window.Top
' and Window.Left properties will be negative. Here,
' we want 0. as the basis for the window.
'
PS.WinTop = 0
PS.WinLeft = 0

Case xlMinimized
'
' In a minimized window, display in the center of
' applicaiton. Force the form to the center of the
' application.
'
HorizOrientation = cstFhpAppCenter
VertOrientation = cstFvpAppCenter

Case xlNormal
PS.WinTop = Abs(ActiveWindow.Top) + DefaultWindowFrameHeight
PS.WinLeft = Abs(ActiveWindow.Left) + DefaultWindowFrameWidth

Case Else
' shouldn't happen
End Select

'''''''''''''''''''''''''''''''''''''''''''''''
' Calculate our BaseLeft and BaseRight values.
' We'll use these as the base relative to which
' the form will actually be positioned.
'
' BaseLeft = LEFT edge of cell
' BaseTop= TOP edge of cell
'
'''''''''''''''''''''''''''''''''''''''''''''''
PS.BaseLeft = PS.AppLeft + PS.WinLeft + PS.HComp + (PS.RngLeft - PS.Cell1Left) + PS.NudgeRight
PS.BaseTop = PS.AppTop + PS.WinTop + PS.VComp + (PS.RngTop - PS.Cell1Top) + PS.NudgeDown

Select Case HorizOrientation

Case cstFhpNull
PS.FrmLeft = 0

Case cstFhpAuto
OptimizeH PS

Case cstFhpFormLeftCellLeft
PS.FrmLeft = PS.BaseLeft + cLeftBump

Case cstFhpFormLeftCellRight
PS.FrmLeft = PS.BaseLeft + PS.RngWidth

Case cstFhpFormLeftCellCenter
PS.FrmLeft = PS.BaseLeft + (PS.RngWidth / 2)

Case cstFhpFormRightCellLeft
PS.FrmLeft = PS.BaseLeft - PS.FrmWidth

Case cstFhpFormRightCellRight
PS.FrmLeft = PS.BaseLeft + PS.RngWidth

Case cstFhpFormRightCellCenter
PS.FrmLeft = PS.BaseLeft + (PS.RngWidth / 2) - PS.FrmWidth

Case cstFhpFormCenterCellLeft
PS.FrmLeft = PS.BaseLeft - (PS.FrmWidth / 2)

Case cstFhpFormCenterCellRight
PS.FrmLeft = PS.BaseLeft + PS.RngWidth - (PS.FrmWidth / 2)

Case cstFhpFormCenterCellCenter
PS.FrmLeft = PS.BaseLeft + (PS.RngWidth / 2) - (PS.FrmWidth / 2)

Case cstFhpAppCenter ' same as Case Else
PS.FrmLeft = PS.AppLeft + (PS.AppWidth / 2) - (PS.FrmWidth / 2)

Case Else ' same as Case cstFhpAppCenter
PS.FrmLeft = PS.AppLeft + (PS.AppWidth / 2) - (PS.FrmWidth / 2)

End Select


Select Case VertOrientation

Case cstFvpNull
PS.FrmTop = 0

Case cstFvpAuto
OptimizeV PS

Case cstFvpFormTopCellTop
PS.FrmTop = PS.BaseTop

Case cstFvpFormTopCellBottom
PS.FrmTop = PS.BaseTop + PS.RngHeight

Case cstFvpFormTopCellCenter
PS.FrmTop = PS.BaseTop + (PS.RngHeight / 2)

Case cstFvpFormBottomCellTop
PS.FrmTop = PS.BaseTop - PS.FrmHeight

Case cstFvpFormBottomCellBottom
PS.FrmTop = PS.BaseTop + PS.RngHeight - PS.FrmHeight

Case cstFvpFormBottomCellCenter
PS.FrmTop = PS.BaseTop - PS.FrmHeight + (PS.RngHeight / 2)

Case cstFvpFormCenterCellTop
PS.FrmTop = PS.BaseTop - (PS.FrmHeight / 2)

Case cstFvpFormCenterCellBottom
PS.FrmTop = PS.BaseTop + PS.RngHeight - (PS.FrmHeight / 2)

Case cstFvpFormCenterCellCenter
PS.FrmTop = PS.BaseTop + (PS.RngHeight / 2) - (PS.FrmHeight / 2)

Case cstFvpAppCenter ' same as case else
PS.FrmTop = PS.AppTop + (PS.AppHeight / 2) - (PS.FrmHeight / 2)

Case Else ' same as cstFvpAppCenter
PS.FrmTop = PS.AppTop + (PS.AppHeight / 2) - (PS.FrmHeight / 2)

End Select

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Finally, after all that, Move the form to the proper Left and Top
' coordinates.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
WhatForm.Move PS.FrmLeft, PS.FrmTop
PositionForm = PS

End Function

Private Sub OptimizeH(P As Positions)
 
levanduyet

levanduyet

Welcome
16/10/04
537
19
18
HCM
my.opera.com
VỊ TRÍ FORM (Phần IV)
''''''''''''''''''''''''''''''''''''''''''''''''''''''
' This procedure optimizes the horizontal position
' of the form. It MUST define SOME (even arbirary)
' horizontal position. First, we try to fit the
' form to the right of the cell. If this is unsuccessful,
' we try to fit the form on the left side of the cell.
' If this is unsuccessful, we try to fit the form centered
' to the cell. If this proves unsuccessful, we
' are stuck with centering the form within the
' application.
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim WinRight As Single
Dim WinLeft As Single

WinLeft = P.Cell1Left
WinRight = P.LastCellLeft + P.LastCellWidth

' The default horizontal position of the form is aligned on the
' right size of the range.

If P.RngLeft + P.RngWidth + P.FrmWidth < WinRight Then
P.FrmLeft = P.BaseLeft + P.RngWidth + cLeftBump
P.OrientationH = cstFhpFormLeftCellRight
Exit Sub
End If

' If we can't fit it on the right, try the left
'
If P.RngLeft - P.FrmWidth > WinLeft Then
P.FrmLeft = P.BaseLeft - P.FrmWidth
P.OrientationH = cstFhpFormRightCellLeft
Exit Sub
End If

' If we can't fit it on the left, try the center
'
If (P.RngLeft + (P.RngWidth / 2) + (P.FrmWidth / 2) <= WinRight) And _
(P.RngLeft + (P.RngWidth / 2) - (P.FrmWidth / 2) >= WinLeft) Then
P.FrmLeft = P.BaseLeft + (P.RngWidth / 2) - (P.FrmWidth / 2)
P.OrientationH = cstFhpFormCenterCellCenter
Exit Sub
End If

' If it won't fit on the in the center, we have to go with AppCenter.
'
P.FrmLeft = P.AppLeft + (P.AppWidth / 2) - (P.FrmWidth / 2)
P.OrientationH = cstFhpAppCenter

End Sub

Private Sub OptimizeV(P As Positions)
''''''''''''''''''''''''''''''''''''''''''''''''''''''
' This procedure optimizes the horizontal position
' of the form. It MUST define SOME (even arbirary)
' horizontal position.
''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim WinTop As Single
Dim WinBottom As Single

WinBottom = P.LastCellTop + P.LastCellHeight
WinTop = P.Cell1Top

' The default position is top aligned. See if we have room
' below.
'
If P.RngTop + P.FrmHeight <= WinBottom Then
P.FrmTop = P.BaseTop
P.OrientationV = cstFvpFormTopCellTop
Exit Sub
End If

' If there is no room below, See if we have room above.
'
If P.RngTop - P.FrmHeight >= WinTop Then
P.FrmTop = P.BaseTop - P.FrmHeight
P.OrientationV = cstFvpFormTopCellTop
Exit Sub
End If

' If there is no room above, try the center
'
If (P.RngTop + (P.RngHeight / 2) - (P.FrmHeight / 2) >= WinTop) And _
(P.RngTop + (P.RngHeight / 2) + (P.FrmHeight / 2) <= WinBottom) Then
P.FrmTop = P.BaseTop + P.RngTop + (P.RngHeight / 2)
P.OrientationV = cstFvpFormCenterCellCenter
Exit Sub
End If
' If we can't put it anywhere else, we have to go with AppCenter
'
P.FrmTop = P.AppTop + (P.AppHeight / 2) - (P.FrmHeight / 2)
P.OrientationV = cstFvpAppCenter
End Sub
Chú ý rằng, module trên chỉ có thể dùng với VBA UserForm. Nó không làm việc với VB Form.
Sau đó tạo một Form và đặt phương thức StartupPosition gía trị : 0-Manual (Điều này rất quan trọng)
Khai báo biến kiểu của vị trí
Dim Ps as Position
Sau đó gọi hàm PositionForm và truyền các tham số sau:
WhatForm: đối tượng UserForm
AnchorRange: ô có mối liên hệ với Form sẽ được thể hiện
NudgeRight: không bắt buộc, số points từ ô có mối liên hệ đến Form sẽ được thể hiện về phía phải. Điều này sẽ hữu ích khi ô có đường viền.
NudgeDown không bắt buộc, tương tự ở trên nhưng về phía dưới.
HorizOrientation không bắt buộc, là một trong những giá trị sau đây:
cstFhpNull = Bên trái của màn hình
cstFhpAppCenter = Tâm của màn hình
cstFhpAuto = Automatic (giá trị đề nghị và là giá trị mặc định)

cstFhpFormLeftCellLeft = Góc bên trái của form tại góc trái của ô
cstFhpFormLeftCellRight = Góc trái của form tại góc phải của ô
cstFhpFormLeftCellCenter = Góc trái của form tại tâm của ô

cstFhpFormRightCellLeft = Góc phải của form tại góc trái của ô
cstFhpFormRightCellRight = Góc phải của form tại góc phải của ô
cstFhpFormRightCellCenter = Góc phải của form tại tâm của ôl

cstFhpFormCenterCellLeft = Tâm của form tại góc trái của ô
cstFhpFormCenterCellRight = Tâm của form tại góc phải của ô
cstFhpFormCenterCellCenter = Tâm của form tại tâm của ô

VertOrientation không bắt buộc. Là một trong các gía trị sau:

cstFvpNull = Đỉnh của màn hình
cstFvpAppCenter = Tâm của màn hình
stFvpAuto = Automatic (giá trị đề nghị và là giá trị mặc định)

cstFvpFormTopCellTop = Vị trí đỉnh của form tại góc trên của ô
cstFvpFormTopCellBottom = Vị trí đỉnh của form tại góc dưới của ô
cstFvpFormTopCellCenter = Vị trí đỉnh của form tại tâm của ô

cstFvpFormBottomCellTop = Góc dưới của form tại góc trên của ô
cstFvpFormBottomCellBottom = Góc dưới của form tại góc dưới của ô
cstFvpFormBottomCellCenter = Góc dưới của form tại tâm của ô

cstFvpFormCenterCellTop = Tâm của form tại đỉnh của ô
cstFvpFormCenterCellBottom = Tâm của form tại góc dưới của ô
cstFvpFormCenterCellCenter = Tâm của form tại tâm của ô
Ví dụ:
PS = PositionForm (UserForm1,Range("C12"),0,0,cstFvpAuto,cstFhpAuto)
Sau đó vị trí của form sẽ dùng giá trị của biến PS
UserForm1.Top = PS.FrmTop
UserForm1.Left = PS.FrmLeft
Và công việc cuối cùng là hiện form bạn muốn:
UserForm1.Show
Tổng hợp các đọan code trên như sau:
Dim PS As Positions
UserForm1.StartupPosition = 0
PS = PositionForm (UserForm1,ActiveCell,0,0,cstFvpAuto,cstFhpAuto)
UserForm1.Top = PS.FrmTop
UserForm1.Left = PS.FrmLeft
UserForm1.Show vbModal
Vâng, vậy nếu các bạn kết hợp điều này với Dataselector thì thật là tuyệt.
Chúc các bạn tìm được điều mình mong muốn.
Lê Văn Duyệt.
 
levanduyet

levanduyet

Welcome
16/10/04
537
19
18
HCM
my.opera.com
THAO TÁC VỚI TẬP TIN DÙNG VBA HAY ĐỐI TƯỢNG FILESEARCH
(Lược dịch từ sách Excel 2000 Power Programming)
Rất nhiều ứng dụng bạn phát triển cho Excel phải làm việc với những file ở bên ngòai. Ví dụ bạn muốn liệt kê các file trong một thư mục, xóa file, đặt lại tên file,vv. Và dĩ nhiên là có thể nhập hay xuất dữ liệu.
VBA cung cấp cho các bạn nhiều hàm và statement (tạm dịch là phát biểu) giúp bạn thao tác với các tập tin lưu trên đĩa. Nếu bạn dùng Excel 2000 bạn có thể dùng đối tượng FileSearch , nó sẽ dễ dàng hơn khi bạn dùng VBA statement và hàm.
Các lệnh VBA bạn có thể dùng để làm việc với các File là:
Lệnh - Command
Mục đích - What it does
ChDir
Thay đổi thư mục hiện tại
CurDrive
Thay đổi ổ đỉa hiện tại
Dir
Trả về tên File hay tên thư mục khớp với ký tự đặc biệt hay thuộc tính của file
FileCopy
Sao chép một file
FileDateTime
Trả về ngày giờ cuối cùng mà file được sửa chữa
FileLen
Trả về kích thước của file (bytes)
GetAttr
Trả về ký tự đại diện cho thuộc tính của file
Kill
Xóa một file
MkDir
Tạo thư mục mới
Name
Đặt tên file hay thư mục
RmDir
Xóa một thư mục rỗng
SetAttr
Thay đổi thuộc tính của file
Vậy để xác định một file có tồn tại hay không ta có thể viết một hàm sau:
Function FileExists(fname) As Boolean
If Dir(fname)<>"" Then
FileExists=True
Else FileExists=False
End Function
fname: đường dẫn có cả tên file
Xin tham khảo bài các hàm tiện ích.
Sử dụng đối tượng FileSearch
Phương thức hay thuộc tính
Mục đích
FileName
Chỉ định tên file (các ký tự thay thế cũng được chấp nhận)
FoundFile
Trả về một đối tượng chứa các tên file được tìm thấy
LookIn
Thư mục cần tìm
SearchSubfolders
Trả về True nếu thư mục con được tìm
Execute
Thực hiện tìm kiếm
NewSearch
Reset lại đối tượng FileSearch
Các bạn hãy đưa đọan mã này vào trong module và thiết lập một nút lệnh trên worksheet của bạn, thiết lập Assign Macro cho nút lệnh là hàm ListFile
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Sub ListFiles()
Msg = "Select a location containing the files you want to list."
Directory = GetDirectory(Msg)
If Directory = "" Then Exit Sub
If Right(Directory, 1) <> "\" Then Directory = Directory & "\"
' Insert headers
r = 1
Cells.ClearContents
Cells(r, 1) = "FileName"
Cells(r, 2) = "Size"
Cells(r, 3) = "Date/Time"
Range("A1:C1").Font.Bold = True
r = r + 1
On Error Resume Next
With Application.FileSearch
.NewSearch
.LookIn = Directory
.Filename = "*.*"
.SearchSubFolders = False
.Execute
For i = 1 To .FoundFiles.Count
Cells(r, 1) = .FoundFiles(i)
Cells(r, 2) = FileLen(.FoundFiles(i))
Cells(r, 3) = FileDateTime(.FoundFiles(i))
r = r + 1
Next i
End With
End Sub
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
' Root folder = Desktop
bInfo.pidlRoot = 0&
' Title in the dialog
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If
' Type of directory to return
bInfo.ulFlags = &H1
' Display the dialog
x = SHBrowseForFolder(bInfo)
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function
Bạn sẽ thấy sự tiện lợi của đối tượng FileSearch.
Chúc các bạn thành công.
Lê Văn Duyệt.
 
W

WhoamI

Cao cấp
Không biết có bác nào gặp trường hợp như thế này không, nhưng em thấy nó rất phổ biến nhất là với kiểu kế toán mỗi ngày học một tí excel như em :

Khi tạo cột TK nợ, TK có hoặc TK đối ứng trong sheet Chứng từ ghi sổ (or Nhật ký chung) thường là kế toán sẽ quên không định dạng trước dữ liệu của cột đó là kiểu Text...
Sau một thời gian nhập chứng từ và định khoản, đến cuối tháng lập Bảng cân đối phát sinh (or Cân đối kế toán) = sumif(), mới thấy Nợ - Có hai bên không bằng nhau. Do không thống nhất định dạng Côt TK ở hai sheet Chứng từ ghi sổ (or Nhật ký chung) với sheet Bảng cân đối phát sinh (or Cân đối kế toán).
Có một vấn đề là sau khi định dạng lại toàn bộ dữ liệu trên cột đó là kiểu Text, nhưng để chuyển định dạng cho các ô có kết quả kiểm tra kiểu dữ liệu = hàm Istext() là false, thì lại phải copy/paste các giá trị giống nhau, hoặc phải kích đúp chuột để kích hoạt ô đó, em thấy rất bất tiện.
Vậy các bác cho em hỏi có cách nào hoặc hàm nào để chuyển định dạng của một ô không ạ?
 
Sửa lần cuối:
F

ForestC

Guest
11/1/05
377
1
0
44
E'rywhere
Thay vì làm từng ô một, em thao tác cho cả cột đi, đề nghị của anh thế này, em nghe xem có được không:

Vì em thường định dạng TK dạng text, vậy thì em sẽ tạm tạo ra một cột trung gian, (sau khi đã hoàn thành yêu cầu rồi thì em xoá đi), em gõ công thức =trim(Ô TK đầu tiên mà em muốn chuyển) . Cái trim đó :D sẽ cắt các ký tự trắng trước và sau của biểu thức trong ngoặc đồng thời nó sẽ chuyển mọi loại định dạng về text (ko rõ có chính xác không ?) . Em copy xuống đến cuối bảng của em. Đó, em làm cho cả 2 cột 1 lúc luôn cho tiện. Sau đó em copy 2 cột trung gian mà em mới tạo ra đó, Dán đặc biệt (Paste Special - Value : Alt-E-S-V) vào vào 2 cột TK Nợ và có của em.

Vâng, đối với trường hợp của em là dạng text, còn nếu anh chị nào dùng kiểu số thì thay hàm =trim(..) bằng hàm =value(...) để chuyển đối tượng trong ngoặc thành dạng số.

Hy vọng 1 chút kinh nghiệm này sẽ giúp được cho công việc của em, còn không thì, hihi, để anh đào 1 cái lỗ nẻ và chui xuống , to be shame lêu lêu :p
 
W

WhoamI

Cao cấp
MaiCa nói:
Thay vì làm từng ô một, em thao tác cho cả cột đi, đề nghị của anh thế này, em nghe xem có được không
Hy vọng 1 chút kinh nghiệm này sẽ giúp được cho công việc của em, còn không thì, hihi, để anh đào 1 cái lỗ nẻ và chui xuống , to be shame lêu lêu :p
Được quá đi ý chứ! Cảm ơn anh Maica nhiều!
W xin đính chính lại câu hỏi trên một chút:
Với hàm sumif() thì không có vấn đề gì, vẫn sum được bình thường. Nhưng nếu sử dụng sum(if())(công thức mảng), sumproduct() thì rất có thể bỏ sót các giá trị do các giá trị đó không giống các giá trị so sánh về kiểu dữ liệu.
 
W

WhoamI

Cao cấp
Hi`! em lại có thắc mắc nữa đây các bác ơi!
Em thường phải làm việc trên 1 bảng tính có rất nhiều dòng và cột, Hiện bảng tính của em chỉ mới lên tới 160 cột thôi nhưng khi em muốn insert thêm cột thì Excel đã báo là :
Can not shift objects off sheet
Sau đó em làm theo đúng help của Excel: Ctrl + end để xóa các cột từ vị trí con trỏ đến cuối bảng tính nhưng lại có một số trường hợp sau sảy ra:
Khi thử insert hoặc hide, hoặc thay đổi độ rộng các cột vẫn bị báo là Can not shift objects off sheet mặc dù số cột Insert thêm + số cột cũ chưa lên tới 256 cột (đã bao gồm các cột chưa có dữ liệu, chưa format).
Em có đọc qua đoạn post của anh Duyệt nhưng vẫn chưa hiểu lý do tại sao ạ! Các bác giúp em với! ..
levanduyet nói:
GIỚI THIỆU VỚI CÁC BẠN MỘT CÁI NHÌN TỔNG QUÁT VỚI EXCEL (2000)
Worksheet
Một trong những kiểu phổ biến nhất của sheet là worksheet. Mỗi một worksheet có 256 cột và 65,536 hàng. Và bạn phải nhớ cho một điều là bạn có thể xóa, ẩn chúng chứ bạn không thể tăng thêm số hàng hay số cột! (Excel 97 chỉ có 16,384 hàng).

How big is a Worksheet - Một Worksheet thì lớn như thế nào?
Có lẻ có một lúc nào đó bạn sẽ hỏi "Một worksheet thì lớn như thế nào?", nếu ta lấy số hàng nhân cho số cột, tức là: (256x65,536)=16,777,216 ô, và nhớ rằng đây chỉ là một worksheet! Nếu bạn dùng chế độ VGA chuẩn thì với độ cao bình thường của hàng và độ rộng bình thường của côt bạn có thể nhìn thấy 9 cột và 18 hàng tại một thời điểm (hay 162 ô). Nếu bạn lấy số 16,777,216 /162 thì bạn sẽ thấy nó lớn như thế nào!
 
B

Bình_OverAC

Over Abnormal / Crazy
14/5/04
846
10
18
42
Nha Trang
Sau khi delete các cột từ cột cuối đên cột 256 xong, bạn save file xong mở lại thử xem. Có thể có hiệu quả đấy. Bạn đang sử dụng Office nào vậy?
 
B

Bình_OverAC

Over Abnormal / Crazy
14/5/04
846
10
18
42
Nha Trang
WhoamI có tô màu từ cột thứ 163 trở đi không! hay bất kỳ loại format nào đó (những loại format ảnh hưởng tới toàn bảng tính kể cả những cột hay dòng tiềm năng). Hảy xóa hết tất cả những dạng format đó! có lẻ sẽ ổn. nhưng nếu vẩn không ổn thì có thể còn có một cách chữa cháy nếu không muốn tiếp tục bị vấn đề này là copy 162 cột này sang sheet mới đi. hi`hi` nếu vậy thì sẽ bị vấn đề nếu bảng tính có công thức liên kết đi chổ khác
 
W

WhoamI

Cao cấp
OverAC nói:
WhoamI có tô màu từ cột thứ 163 trở đi không! hay bất kỳ loại format nào đó (những loại format ảnh hưởng tới toàn bảng tính kể cả những cột hay dòng tiềm năng).
Không mà, mình đã xóa bằng Delete từ cột 163 trở đi sau đó từ cột 163 bảng tính chyển sang màu xám, không thao tác được gì ở trên đó nữa cơ.
OverAC nói:
nhưng nếu vẩn không ổn thì có thể còn có một cách chữa cháy nếu không muốn tiếp tục bị vấn đề này là copy 162 cột này sang sheet mới đi. hi`hi` nếu vậy thì sẽ bị vấn đề nếu bảng tính có công thức liên kết đi chổ khác
Giải pháp này đúng là không ổn rồi! hu..hu...
 
H

handung107

Cao cấp
28/8/04
576
15
0
VN
www.giaiphapexcel.com
Thật ra, việc xây dựng một bảng tính gọn, nhẹ là điều rất cần thiết. Bạn có thể thiết kế sao cho thành nhiều Sheet, hoặc tổ chức thành nhiều Workbook khác nhau và cho liên kết lại với nhau. Bảng tính Excel với nhiều công thức dễ đưa đến những tham chiếu vòng, những công thức rườm rà, những tên quá nhiều, thêm vào là những Macro, định dạng khiến bảng tính dễ có những lỗi xảy ra mà không ai hiểu vì sao.
Một Sheet dù được tối đa là 256 cột, nhưng thực sự, bảng tính Excel chỉ nên sử dụng khoảng vài chục cột, và khoảng 1000 dòng. Đó là ý kiến của nhiều người, nên WhoamI cần xem xét thiết kế lại trang bảng tính sao cho phù hợp hơn nhé
 
W

WhoamI

Cao cấp
handung107 nói:
nên WhoamI cần xem xét thiết kế lại trang bảng tính sao cho phù hợp hơn nhé
Vâng ạ! Em sẽ rút kinh nghiệm chị à!
Đúng là qua tình huống này và chắc là còn rất nhiều tình huống khác mới thấy việc tổ chức dữ liệu trong excel rất quan trọng và cần thiết vô cùng. Vì thế em đang rất nóng lòng chờ bài viết về Xây dựng cơ sơ dữ liệu trên Excel đó chị. Và mọi việc sẽ dần dần được gợi mở.
 

Xem nhiều

Webketoan Zalo OA