HeSanbi
Nam Nhân✨Hiếu Lễ Nghĩa Trí Tín✨
- Tham gia
- 24/2/13
- Bài viết
- 2,382
- Được thích
- 3,536
- Giới tính
- Nam
***** CẬP NHẬT BẢN 2.1 *****
Cập nhật lại toàn bộ mã sử dụng XML để gộp ô giữ định dạng
Chức năng mới:
HÀM UDF TỰ ĐỘNG NỐI CHUỖI GIỮ ĐỊNH DẠNG
với Hàm JoinCells
=JoinCells(CopyToCell,sentenceSpace,Values,...)
Hướng dẫn sử dụng hàm:
Cách viết hàm nhanh, gõ vào ô chuỗi =JoinCells và ấn tổ hợp phím Ctrl+Shift+A
Ví dụ: gộp các chuỗi từ các ô C1 đến C4, phân cách là dấu cách, trả vào ô B1
Để tự động Gộp ô từ B1 đến B5 hãy gõ thêm B1:B5: =JoinCells(B1:B5, " ",C1:C4)
Ở đây ô C1 là ô đầu tiên nhập vào nên được chọn làm ô để đặt chiều rộng cột ô đã gộp.
***Bên dưới có hai tập tin, bao gồm: tập tin Mã trong Module và mã trong Class Module nhầm tiết kiệm bộ nhớ sau khi chạy.
Để sử dụng được hàm JoinCells trong ứng dụng Excel của bạn hãy sao chép mã vào Module mới.
---------------------------------------------------------
Bạn có thể đọc thêm các bài biết của tôi tại tag #sanbi udf
Cập nhật lại toàn bộ mã sử dụng XML để gộp ô giữ định dạng
Chức năng mới:
- Chức năng gộp mới giúp gộp chính xác gồm: phông, màu, thụt dòng, nền, ...
- Viết mã trong Class Module để tiết kiệm bộ nhớ.
- Cải thiện tốc độ gộp nhanh đáng kể.
HÀM UDF TỰ ĐỘNG NỐI CHUỖI GIỮ ĐỊNH DẠNG
với Hàm JoinCells
=JoinCells(CopyToCell,sentenceSpace,Values,...)
Hướng dẫn sử dụng hàm:
Vị trí | Tham số | Kiểu | Chức năng |
1 | toCell | Ô | Ô trả kết quả |
2 | sentenceSpace | Chuỗi | Dấu phân cách khi nối chuỗi |
3 | Values | Các ô hoặc chuỗi | Các ô cần nối chuỗi |
Cách viết hàm nhanh, gõ vào ô chuỗi =JoinCells và ấn tổ hợp phím Ctrl+Shift+A
Ví dụ: gộp các chuỗi từ các ô C1 đến C4, phân cách là dấu cách, trả vào ô B1
Cách 1: =JoinCells(B1, " ",C1,C2,C3,C4)
Cách 2: =JoinCells(B1, " ",C1:C4)
Cách 3 (gộp tại ô giá trị): =JoinCells(C1:C4, " ",C1:C4)
Cách 4: =JoinCells(B1, Char(10),C1:C4)
Cách 5: =JoinCells(B1, " ",C1," Chào ",C2," tôi đây ",C3,C4)
Để tự động Gộp ô từ B1 đến B5 hãy gõ thêm B1:B5: =JoinCells(B1:B5, " ",C1:C4)
Ở đây ô C1 là ô đầu tiên nhập vào nên được chọn làm ô để đặt chiều rộng cột ô đã gộp.
***Bên dưới có hai tập tin, bao gồm: tập tin Mã trong Module và mã trong Class Module nhầm tiết kiệm bộ nhớ sau khi chạy.
Để sử dụng được hàm JoinCells trong ứng dụng Excel của bạn hãy sao chép mã vào Module mới.
---------------------------------------------------------
Bạn có thể đọc thêm các bài biết của tôi tại tag #sanbi udf
JavaScript:
Option Explicit
Private Const projectUDFName = "joinCells"
Private Const projectUDFFileName = "joinCells"
Private Const projectUDFVersion = "2.1"
Private Const urlGithub = ""
#If VBA7 Then
#Else
Private Enum LongLong:[_]:End Enum
#If Win64 Then
#Else
Private Enum LongPtr:[_]:End Enum
#End If
#End If
Private Const PtrNull As LongPtr = 0
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT) 'Use for hwnd
Private Const NAME_MAX_LENGTH = 1024
#If VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "User32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
Private Declare PtrSafe Function KillTimer Lib "User32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
Private Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If
#If Mac Then
''
#Else
#If VBA7 Then
Private Declare PtrSafe Function OpenClipboard Lib "User32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function RegisterClipboardFormat Lib "User32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As LongPtr
Private Declare PtrSafe Function EmptyClipboard Lib "User32" () As LongPtr
Private Declare PtrSafe Function CloseClipboard Lib "User32" () As LongPtr
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "User32" (ByVal wFormat As LongPtr) As LongPtr
Private Declare PtrSafe Function GetClipboardData Lib "User32" (ByVal wFormat As LongPtr) As LongPtr
Private Declare PtrSafe Function SetClipboardData Lib "User32" (ByVal wFormat As LongPtr, ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As LongPtr
Private Declare PtrSafe Function GlobalLock Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongPtr
'NOTE: These declarations are not provided in https://stackoverflow.com/questions/35416662/text-to-clipboard-in-vba-windows-10-issue
Private Declare PtrSafe Function EnumClipboardFormats Lib "User32" (ByVal wFormat As LongPtr) As LongPtr
Private Declare PtrSafe Function GetClipboardFormatName Lib "User32" Alias "GetClipboardFormatNameA" (ByVal wFormat As LongPtr, ByVal lpString As String, ByVal nMaxCount As Long) As LongPtr
Private Declare PtrSafe Function GlobalFree Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
#Else
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
'Note that we do not use the GetClipboardDataA declaration
'Private Declare Function GetClipboardData Lib "user32" Alias "GetClipboardDataA" (ByVal wFormat As Long) As Long
Private Declare Function GetClipBoardData Lib "user32" Alias "GetClipboardData" (ByVal wFormat As Long) As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
'NOTE: the lstrCpy declaration you get from the VB6 API Viewer is WRONG. It's version is this:
'Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
'the code from this thread, use:
'Private Declare Function lstrCpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
'Replacing with that used in https://stackoverflow.com/questions/35416662/text-to-clipboard-in-vba-windows-10-issue
Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
'NOTE: These declarations are not provided in https://stackoverflow.com/questions/35416662/text-to-clipboard-in-vba-windows-10-issue
Private Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
#End If
#End If
Private Const MaxH = 1450, MaxV = 409
Private Type FontFormatArguments
action As Long
direction As Long
target As Range
caller As Range
Address As String
Formula As String
cells As Variant
SentenceSpace As String
removeBackground As Boolean
End Type
''''///////////////////////////////////////////////////////
Private ContainCells As New VBA.Collection, FitDisable As Boolean
Private Works() As FontFormatArguments
Private Glb_ClipboardText As String
Private Const spSentenceSpace = "\\Sentence\\"
Function jcSentenceSpace(SentenceSpace$) As String
jcSentenceSpace = spSentenceSpace & SentenceSpace
End Function
Function joinCells(ByVal copyToCell As Range, ByVal SentenceSpace$, ParamArray Params())
On Error Resume Next
Dim R As Object, s$, k%, i%, p, j%
Set R = Application.ThisCell
If Err Then
Debug.Print "joinCells Error: Please call function JoinCellsByXml In VBA"
Exit Function
End If
If R.Parent Is copyToCell.Parent Then
If Not Intersect(R, copyToCell) Is Nothing Then
joinCells = "[joinCells:Error]" & "L" & ChrW(7895) & "i " & ChrW(244) & " tr" & ChrW(7843) & " k" & ChrW(7871) & "t qu" & ChrW(7843) & "!"
Exit Function
End If
End If
s = R.Address(0, 0, external:=1)
k = UBound(Works)
For i = 1 To k
With Works(i)
If .Address = s Then
Select Case .action
Case 0, 1: Exit Function
Case 3:: j = 1: .action = 4
joinCells = "joinCells: Ho" & ChrW(224) & "n th" & ChrW(224) & "nh"
GoTo n
Case Else: Exit Function
End Select
End If
End With
Next
k = k + 1: ReDim Preserve Works(1 To k)
With Works(k)
.Address = s
Set .caller = R
.cells = Params
Set .target = copyToCell
.SentenceSpace = SentenceSpace
' For Each p In Params
' If TypeName(p) = "String" Then
' If p Like spSentenceSpace & "*" Then
' .SentenceSpace = Mid(p, Len(spSentenceSpace) + 1): Exit For
' End If
' End If
' Next
.Formula = R.Formula
.action = 1
End With
joinCells = "joinCells: " & ChrW(272) & "ang g" & ChrW(7897) & "p"
n:
Call SetTimer(Application.hwnd, 241215 + j, 0, AddressOf joinCells_callback)
On Error GoTo 0
End Function
Private Sub joinCells_callback(ByVal hwnd As LongPtr, ByVal wMsg As LongPtr, ByVal idEvent As LongPtr, ByVal dwTime As LongPtr)
On Error Resume Next
KillTimer hwnd, idEvent
Select Case idEvent
Case 241215: Call joinCells_working
Case 241216:
Dim u%, k%, i%: u = UBound(Works)
If u > 0 Then
For i = 1 To u
If Works(i).action = 4 Then k = k + 1
Next
If k >= u Then Erase Works
End If
End Select
End Sub
Sub joinCells_working()
On Error Resume Next
Dim A As Application, b As FontFormatArguments, i&, k&, cell As Range
Dim u%, su As Boolean, Ac As Boolean, ec As Boolean
u = UBound(Works)
For i = 1 To u
b = Works(i)
Select Case b.action
Case 1
If A Is Nothing Then
Set A = b.caller.Parent.Parent.Parent
su = A.ScreenUpdating: If su Then A.ScreenUpdating = False
Ac = A.Calculation: If Ac = xlCalculationAutomatic Then A.Calculation = xlCalculationManual
ec = A.EnableEvents: If ec Then A.EnableEvents = False
Set cell = Selection
If cell Is Nothing Then Set cell = ActiveWindow.ActivePane.VisibleRange
End If
Works(i).action = 2
JoinCellsByXml b.target, b.cells, b.SentenceSpace
Works(i).action = 3
b.caller.Formula = b.Formula
n:
End Select
Next
If Not A Is Nothing Then
If Not cell Is Nothing Then Application.Goto cell, 0: Application.Goto cell(1, 1), 0
If su And A.ScreenUpdating <> su Then A.ScreenUpdating = su
If Ac = xlCalculationAutomatic And Ac <> A.Calculation Then A.Calculation = Ac
If ec And A.EnableEvents <> ec Then A.EnableEvents = ec
End If
On Error GoTo 0
End Sub
Private Sub JoinCellsByXml_test_test()
Dim s$, re
s = encodeTextXML2(Selection.Value(11))
Set re = glbRegex
re.Pattern = "<!--(.*?)-->|\r?\n\s*\B"
Debug.Print s
's = re.Replace(s, "")
ClipboardSetXML s
End Sub
Private Sub JoinCellsByXml_test()
[Sheet1].Range("B1:B7").ClearContents
JoinCellsByXml [Sheet1].Range("B1:B7"), Array([Sheet1].Range("C1,C2,C3,C4,C5"), Chr(10))
End Sub
Sub JoinCellsByXml(ByVal toCell As Range, Values, Optional ByVal SentenceSpace$)
Dim re, re2, s$, s0$, s1$, s2$, s4$, i&, l&, t, m, ms, m2, ms2, ms3, x, irg, area, z$, sts$, z0$, z1$, st$, fm$, idt%
Dim styles$, dfStyle$, tbID$, tbIDT%, tbStyle$, tbFormat$, pt$, styleID$, cStyle$, cFormat$, cIdt%, nr, nc, cell As Range, sh As Object
Dim ssParent$, v0$, v1$
nr = toCell.rows.Count: nc = toCell.Columns.Count
Set re = glbRegex
Set re2 = glbRegex
sts = SentenceSpace
If sts <> Empty Then sts = "<Font>" & encodeTextXML(sts) & "</Font>"
Set cell = ActiveWindow.ActivePane.VisibleRange
If Not cell.Parent Is toCell.Parent Then
toCell.Parent.Activate
Set cell = ActiveWindow.ActivePane.VisibleRange
End If
For Each irg In Values
If IsObject(irg) Then
For Each area In irg.Areas
s = area.Value(11)
'Debug.Print s
If s Like "*<Row*" Then GoSub clean: GoSub cell
Next
Else
s = irg
Select Case True
Case s Like spSentenceSpace & "*"
Case Else: z = z & "<Font >" & encodeTextXML(CStr(irg)) & "</Font>"
End Select
End If
Next
v0 = z: GoSub removeDUP: z = v0
s0 = ""
If nr > 1 Then s0 = " ss:MergeDown=""" & CStr(nr - 1) & """ "
If nc > 1 Then s0 = s0 & " ss:MergeAcross=""" & CStr(nc - 1) & """ "
If s0 <> Empty Then
s0 = Replace(IIf(z0 = Empty, z1, z0), "<Cell ", "<Cell " & s0)
Else
s0 = IIf(z0 = Empty, z1, z0)
End If
z = s0 & z & "</" & IIf(z0 = Empty, "", "ss:") & "Data></Cell></Row></Table></Worksheet></Workbook>"
Application.DisplayAlerts = False
toCell.MergeCells = False
Application.Goto toCell, False
ClipboardSetXML z
toCell.Worksheet.Paste
Application.DisplayAlerts = True
Exit Sub
removeDUP:
v1 = "Size": GoSub remove: GoSub remove
v1 = "FontName": GoSub remove: GoSub remove
v1 = "Color": GoSub remove: GoSub remove
Return
remove:
re.Pattern = "html:" & v1 & "=""[^""]+""([^>]*html:" & v1 & "=""[^""]+"")": If re.Test(v0) Then v0 = re.Replace(v0, "$1")
Return
clean:
re.Pattern = "<!--(.*?)-->|\r?\n\s*\B"
s = re.Replace(s, "")
s = Replace(s, "</Data></Cell>", "</ss:Data></Cell>")
x = InStr(1, s, "</Styles><Worksheet")
s0 = Left$(s, x)
st = "Default": GoSub getStyle: dfStyle = st
re.Pattern = "<Table [^>]*ss:StyleID=""([^""]+)""[^>]*>":
Set ms = re.Execute(s): tbID = "": tbStyle = "": tbFormat = "": tbIDT = 0
If ms.Count Then
tbID = ms(0).SubMatches(0): st = tbID: GoSub getStyle: tbStyle = st: tbFormat = fm: tbIDT = idt
If ssParent <> "" Then
st = ssParent: GoSub getStyle:
If st <> Empty Then
tbStyle = st & " " & tbStyle
End If
End If
End If
If z0 = Empty Then
re.Pattern = "(.*<Worksheet[^>]*><Table +ss:ExpandedColumnCount="")(\d+)("" +ss:ExpandedRowCount="")(\d+)(""[^>]*><Column[^>]*/>).*":
If re.Test(s) Then
re2.Pattern = "<Row[^>]*><Cell[^>]*><[^>]*xmlns=""[^>]*""[^>]*>"
If z1 = Empty Then z1 = re.Replace(s, "$1" & nc & "$3" & nr & "$5")
If re2.Test(s) Then z0 = re.Replace(s, "$1" & nc & "$3" & nr & "$5") & re2.Execute(s)(0)
End If
End If
Return
cell:
re.Pattern = "<Cell(?:(?: *ss:StyleID=""([^""]+)"")|[^>]*)>(?:<(?:ss:)?Data ss:Type=""([^""]+)""[^>]*>)(.*?)(?:</(?:ss:)?Data>)?</Cell>"
Set ms = re.Execute(s)
For Each m In ms
s2 = CStr(m.SubMatches(2))
s4 = CStr(m.SubMatches(1))
styleID = CStr(m.SubMatches(0))
If styleID = Empty Then
If tbID = Empty Then
cStyle = dfStyle: cFormat = "": cIdt = 0
Else
cStyle = tbStyle: cFormat = tbFormat: cIdt = tbIDT
End If
Else
st = styleID: GoSub getStyle: cStyle = st: cFormat = fm: cIdt = idt
If ssParent <> "" Then
st = ssParent: GoSub getStyle:
If st <> Empty Then
cStyle = st & " " & cStyle
End If
End If
End If
Select Case s4
Case "DateTime", "Number": '2023-01-22T00:00:00.000
Select Case s4
Case "DateTime"
s2 = Left(s2, Len(s2) - 4)
s2 = Replace(Replace(s2, "T", " "), "-", "/")
s2 = Format(CDate(s2), cFormat)
Case "Number": s2 = Format(s2, cFormat)
End Select
End Select
If Not s2 Like "*<Font *>*</Font>*" Then
s2 = "<Font >" & s2 & "</Font>"
If cStyle Like "*html:VerticalAlign=""Superscript""*" Then s2 = "<Sup>" & s2 & "</Sup>"
If cStyle Like "*html:VerticalAlign=""Subscript""*" Then s2 = "<Sub>" & s2 & "</Sub>"
If cStyle Like "*html:Underline=*" Then
s2 = "<U html:Style=""text-underline:" & LCase(Split(Split(cStyle, "html:Underline=""")(1), """")(0)) & """>" & s2 & "</U>"
End If
If cStyle Like "*html:StrikeThrough=*" Then s2 = "<S>" & s2 & "</S>"
If cStyle Like "*html:Bold=*" Then s2 = "<B>" & s2 & "</B>"
If cStyle Like "*html:Italic=*" Then s2 = "<I>" & s2 & "</I>"
End If
s2 = IIf(cIdt = 0, "", "<Font>" & Space(cIdt * 4) & "</Font>") & Replace(s2, "<Font ", "<Font " & cStyle & " ")
GoSub encode
If z = Empty Then z = s2 Else z = z & sts & s2
Next
Return
getStyle:
re.Pattern = "<Style ss:ID=""" & st & """(?: ss:Parent=""([^""]*)"")?.*?</Style>": Set ms2 = re.Execute(s0)
If ms2.Count = 0 Then st = "": fm = "": Return
s1 = ms2(0): ssParent = ""
If ms2(0).SubMatches.Count Then ssParent = ms2(0).SubMatches(0)
re.Pattern = "<Style ss:ID=""" & st & """[^>]*>.*?<Font ([^>]*?)/>": Set ms2 = re.Execute(s1)
If ms2.Count Then
st = ms2(0).SubMatches(0)
re.Pattern = " *x:[^=]+=""[^""]+""": st = re.Replace(st, ""):
st = Replace(st, "ss:", "html:")
Else
st = ""
End If
re.Pattern = "<NumberFormat [^>]*?ss:Format=""([^""]*)"""
Set ms2 = re.Execute(s1)
If ms2.Count Then
fm = ms2(0).SubMatches(0)
Else
fm = ""
End If
re.Pattern = "<Alignment [^>]*?ss:Indent=""([^""]*)"""
Set ms2 = re.Execute(s1)
If ms2.Count Then
idt = ms2(0).SubMatches(0)
Else
idt = 0
End If
Return
encode:
x = 1
l:
l = Len(s2)
For i = x To l
t = Mid(s2, i, 1): m = AscW(t)
If m > 127 Or m < 1 Then
s2 = Replace(s2, t, "&#" & CStr(m) & ";")
x = i + Len(m) + 2: GoTo l
End If
Next
Return
End Sub
Private Sub SetNewHeightArea_test()
SetNewHeightArea [A26], [d3]
End Sub
Private Function SetNewHeightArea(ByVal NewCell As Range, ByVal CellMerge As Range) As Boolean
Const MaxV = 409
Dim h1!, h2!, k&
h2 = CellMerge.MergeArea.height
If h2 > MaxV Then
Exit Function
End If
h1 = h2 / 6.05
NewCell.EntireRow.RowHeight = h1
If NewCell.height >= h2 Then
Do
h1 = h1 - 0.3
NewCell.EntireRow.RowHeight = h1
k = k + 1
Loop Until NewCell.height <= h2
End If
Do Until NewCell.height >= h2
h1 = h1 + 0.1
k = k + 1
NewCell.EntireRow.RowHeight = h1
Loop
SetNewHeightArea = True
End Function
Function S_Cells(ParamArray cells()) As String
Dim s$, p As Object
On Error Resume Next
Set ContainCells = New VBA.Collection
s = "S_Cells:" & Application.caller.Address(0, 0, external:=1)
S_Cells = s
Set p = Nothing
Set p = ContainCells(s)
If Not p Is Nothing Then
ContainCells.remove s
End If
ContainCells.Add cells, s
End Function
Private Function cellsIntersect(cells1 As Range, ByVal cells2 As Range, Optional refcells As Range) As Range
If cells1 Is Nothing Then
Set cells1 = cells2
Exit Function
ElseIf cells2 Is Nothing Then
Exit Function
End If
If Not cells1.Worksheet Is cells2.Worksheet Then
Exit Function
End If
Set cellsIntersect = Application.Intersect(cells1, cells2)
Set cells1 = Application.Union(cells1, cells2)
If refcells Is Nothing Then
Set refcells = cells1.Worksheet.Range(cells1, cells2)
Else
Set refcells = cells1.Worksheet.Range(cells1, refcells)
Set refcells = cells1.Worksheet.Range(cells2, refcells)
End If
End Function
Private Function newUnion(cells1 As Range, ByVal cells2 As Range) As Boolean
If cells1 Is Nothing Then
Set cells1 = cells2
Exit Function
ElseIf cells2 Is Nothing Then
Exit Function
End If
If Not cells1.Worksheet Is cells2.Worksheet Then
Exit Function
End If
newUnion = Not Application.Intersect(cells1, cells2) Is Nothing
Set cells1 = Application.Union(cells1, cells2)
End Function
Private Function NewHeightArea(ByVal MergeCells As Range, ByVal height!) As Boolean
Const MaxV = 409
Set MergeCells = MergeCells.MergeArea
Dim h1!, h2!, k&, i&, R&, e As Boolean
i = MergeCells.rows.Count
If height > MaxV * i Then
Exit Function
End If
Dim t As Single: t = Timer
h1 = height / i
GoSub R
If h2 > height Then
Do
h1 = h1 - 0.1
GoSub R
Loop Until h2 <= height
End If
Do Until h2 >= height
h1 = h1 + 0.1
GoSub R
Loop
e:
Debug.Print "NewHeightArea-Timer: "; Round(Timer - t, 2)
NewHeightArea = True
Exit Function
R:
k = k + 1
For R = 1 To i
MergeCells(R, 1).EntireRow.RowHeight = h1
h2 = MergeCells.EntireRow.height
If h2 > height - 1 And h2 < height + 1 Then
GoTo e
End If
Next
Return
End Function
Private Function readHTMLFile2(strFile As String) As String
Dim f As Long, s$: f = FreeFile
Open strFile For Input As #f
s = Input$(LOF(f), #f)
Close #f
''s = Join(Split(s, vbNewLine & " "), vbNullString)
''s = Join(Split(s, vbNewLine), " ")
readHTMLFile2 = s
End Function
Function savedClipboardText() As Boolean
Static ClipboardText$, b As Boolean
b = ClipboardText = vbNullString
If b Then
ClipboardText = ClipBoard
Else
TextToClipBoard ClipboardText
ClipboardText = vbNullString
End If
savedClipboardText = b
End Function
Function TextToClipBoard(ByVal text As String) As String
#If Mac Then
With New MSForms.DataObject
.SetText text: .PutInClipboard
End With
#Else
Dim hGlobalMemory As LongPtr
Dim hClipMemory As LongPtr
Dim lpGlobalMemory As LongPtr
Dim x As LongPtr
hGlobalMemory = GlobalAlloc(&H42, Len(text) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, text)
If GlobalUnlock(hGlobalMemory) <> 0 Then
TextToClipBoard = "Could not unlock memory location. Copy aborted."
GoTo PrepareToClose
End If
If OpenClipboard(0&) = 0 Then
TextToClipBoard = "Could not open the Clipboard. Copy aborted."
Exit Function
End If
x = EmptyClipboard()
savedClipboardText
hClipMemory = SetClipboardData(1, hGlobalMemory)
PrepareToClose:
If CloseClipboard() = 0 Then
TextToClipBoard = "Could not close Clipboard."
End If
#End If
End Function
Private Function ClipBoard()
On Error GoTo OutOfHere
Const GHND = &H42
Const CF_TEXT = 1
Const MAXSIZE = 4096
Dim hGlobalMemory As LongPtr
Dim hClipMemory As LongPtr
Dim lpGlobalMemory As LongPtr
Dim lpClipMemory As LongPtr
Dim RetVal As LongPtr
Dim MyString As String
If OpenClipboard(0&) = 0 Then
''MsgBox "Cannot open Clipboard. Another app. may have it open"
Exit Function
End If
'' Obtain the handle to the global memory
'' block that is referencing the text.
hClipMemory = GetClipboardData(CF_TEXT)
If IsNull(hClipMemory) Then
MsgBox "Could not allocate memory"
GoTo OutOfHere
End If
'' Lock Clipboard memory so we can reference
'' the actual data string.
lpClipMemory = GlobalLock(hClipMemory)
If Not IsNull(lpClipMemory) Then
MyString = Space$(MAXSIZE)
RetVal = lstrcpy(MyString, lpClipMemory)
RetVal = GlobalUnlock(hClipMemory)
'' Peel off the null terminating character.
MyString = Mid(MyString, 1, InStr(1, MyString, Chr$(0), 0) - 1)
Else
''MsgBox "Could not lock memory to copy string from."
End If
OutOfHere:
RetVal = CloseClipboard()
ClipBoard = MyString
End Function
Private Sub ClipboardSetXML(ByVal XML As String)
Dim lpMemory As LongPtr
Dim hMemory As LongPtr
Dim wLen As Long
Dim RetVal As Variant
Dim memoryIsLocked As Boolean
Dim memoryIsAllocated As Boolean
Dim clipBoardIsOpen As Boolean
Dim thisClipboardFormatNumber As Long
On Error GoTo ErrorHandler
'Get the length, including one extra for a CHR$(0) at the end.
wLen = Len(XML) + 1
'Add a null to the end
XML = XML & Chr$(0)
'Allocate some memory
hMemory = GlobalAlloc(GHND, wLen + 1)
If hMemory = PtrNull Then
Err.Raise vbObjectError + 1001, "vbaClipboard", "Unable To allocate memory."
Else
memoryIsAllocated = True
End If
lpMemory = GlobalLock(hMemory)
If lpMemory = PtrNull Then
'Throw an error
Err.Raise vbObjectError + 1001, "vbaClipboard", "Unable To lock memory."
Else
memoryIsLocked = True
End If
'Copy our string into the locked memory.
RetVal = lstrcpy(lpMemory, XML)
'Don't send clipboard locked memory.
RetVal = GlobalUnlock(hMemory)
'If the preceding throws an error, it will be handled in ErrorHandler
memoryIsLocked = True
If OpenClipboard(0&) = PtrNull Then
Err.Raise vbObjectError + 1, "vbaClipboard", "Unable To open Clipboard. Perhaps some other application Is using it."
Else
clipBoardIsOpen = True
End If
'Is the requested format one of the Windows built-in formats
Dim i As Integer
If thisClipboardFormatNumber = 0 Then
'Nope. Register the format
On Error Resume Next
thisClipboardFormatNumber = CLng(RegisterClipboardFormat("XML Spreadsheet")) 'Note: Adding this to support 64Bit
If Err.Number <> 0 Then
Err.Raise vbObjectError + 1, "vbaClipboard", "Unable To register clipboard format: " & "XML Spreadsheet" & _
". Error message: " & Err.description
End If
On Error GoTo ErrorHandler
If thisClipboardFormatNumber = 0 Then Err.Raise vbObjectError + 1, "vbaClipboard", "Unable To register clipboard format: " & "XML Spreadsheet"
End If
'Empty the clipboard
If EmptyClipboard() = PtrNull Then Err.Raise vbObjectError + 1, "vbaClipboard", "Unable To Empty the clipboard."
If SetClipboardData(thisClipboardFormatNumber, hMemory) = PtrNull Then Err.Raise vbObjectError + 1, "vbaClipboard", "Unable To Set the clipboard data."
CloseClipboard
GlobalFree hMemory
Exit Sub
ErrorHandler:
Dim description As String
description = Err.description
On Error Resume Next
If memoryIsLocked Then GlobalUnlock hMemory
If memoryIsAllocated Then GlobalFree hMemory
If clipBoardIsOpen Then CloseClipboard
On Error GoTo 0
Err.Raise vbObjectError + 1, "vbaClipboard", description
End Sub
Private Function SetNewWidthArea(ByVal NewCell As Range, ByVal CellMerge As Range) As Boolean
Dim w!, W2!, k&
W2 = CellMerge.MergeArea.Columns.Width
If W2 > MaxH Then
Exit Function
End If
w = W2 / 6.05
NewCell.EntireColumn.ColumnWidth = w
If NewCell.Width >= W2 Then
Do
w = w - 0.3
NewCell.EntireColumn.ColumnWidth = w
k = k + 1
Loop Until NewCell.Width <= W2
End If
Do Until NewCell.Width >= W2
w = w + 0.1
k = k + 1
NewCell.EntireColumn.ColumnWidth = w
Loop
SetNewWidthArea = True
End Function
Private Function encodeTextXML(ByVal text$)
Dim l, i, x, t, m
x = 1
l:
l = Len(text)
For i = x To l
t = Mid(text, i, 1): m = AscW(t)
Select Case m
Case Is > 127, Is < 1, 60, 62, 10, 13
text = Replace(text, t, "&#" & CStr(m) & ";")
x = i + Len(m) + 2
GoTo l
End Select
Next
encodeTextXML = text
End Function
Private Function encodeTextXML2(ByVal text$)
Dim l, i, x, t, m
x = 1
l:
l = Len(text)
For i = x To l
t = Mid(text, i, 1): m = AscW(t)
Select Case m
Case Is > 127, Is < 1
text = Replace(text, t, "&#" & CStr(m) & ";")
x = i + Len(m) + 2
GoTo l
End Select
Next
encodeTextXML2 = text
End Function
Private Function glbRegex(Optional bglobal As Boolean = True, Optional IgnoreCase As Boolean = True, Optional MultiLine As Boolean = True) As Object
Set glbRegex = CreateObject("VBScript.RegExp")
With glbRegex: .Global = bglobal: .IgnoreCase = IgnoreCase: .MultiLine = MultiLine: End With
End Function
Lần chỉnh sửa cuối:
