HeSanbi
Nam Nhân✨Hiếu Lễ Nghĩa Trí Tín✨
- Tham gia
- 24/2/13
- Bài viết
- 2,809
- Được thích
- 4,543
- Giới tính
- Nam
Xin chào các bạn hôm nay tôi chia sẻ cho các bạn kiến thức xử lý chuỗi và mảng trong VBA tại Memory để tốc độ xử lý nhanh hơn.
Mẹo xử lý chuỗi và mảng tại Memory này rất đơn giản, giúp các bạn tăng tốc mã, tiết kiệm khá nhiều thời gian chạy.
XỬ LÝ KÝ TỰ CHUỖI
Bài viết dưới đây tận dụng hàm API RtlMoveMemory
Ví dụ lặp qua từng ký tự chuỗi:
Lưu ý: bộ nhớ từng kiểu biến là khác nhau, không thể tùy ý sao chép bộ nhớ. Sẽ làm sập tiến trình VBA và Excel.
XỬ LÝ MẢNG - TRANSPOSE
(Tiếng Việt trong mã sử dụng font Courier new Vietnamese)
Lưu ý: Trong hàm ArrayTranspose tôi sử dụng vòng lặp For, để nhanh hơn nữa hãy tận dụng vòng lặp For Each.
XỬ LÝ MẢNG - ĐẢO, XOAY, CẮT
Mẹo xử lý chuỗi và mảng tại Memory này rất đơn giản, giúp các bạn tăng tốc mã, tiết kiệm khá nhiều thời gian chạy.
XỬ LÝ KÝ TỰ CHUỖI
Bài viết dưới đây tận dụng hàm API RtlMoveMemory
JavaScript:
#If VBA7 Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#Else
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
#End If
Private Type mmStr
s(1) As Byte
End TypeVí dụ lặp qua từng ký tự chuỗi:
Đoạn mã dưới đây, có hai phương thức: 1 là sao chép bộ nhớ và 2 là sử dụng hàm MID để lặp qua 10 triệu ký tự.
Tốc độ là xử lý memory nhanh xấp xỉ gắp đôi hàm MID$ (có ký tự $ nhanh hơn)
JavaScript:
Private Sub SplitStringToCharArray_test()
Dim a() As mmStr, s$, l&, b() As String, t1, t2, t3, v$
s = String(10000000, "a"):
t1 = Timer
l = Len(s)
ReDim a(1 To l)
CopyMemory ByVal VarPtr(a(1)), ByVal StrPtr(s), l * 2
For i = 1 To l
v = a(i).s
Next
t2 = Timer
ReDim b(1 To l)
For i = 1 To l
b(i) = Mid$(s, i, 1)
Next
Debug.Print "Mem: "; t2 - t1, "MID: " Timer - t2
End Sub
Giải thuật ở trên là sao chép lại chuỗi từ vùng nhớ gán vào Type có 2 byte bộ nhớ. Vì chuỗi cũng cần 2 byte để lưu trữ nên việc gán này sẽ tương thích.
Lưu ý: bộ nhớ từng kiểu biến là khác nhau, không thể tùy ý sao chép bộ nhớ. Sẽ làm sập tiến trình VBA và Excel.
XỬ LÝ MẢNG - TRANSPOSE
Dưới đây là hàm Transpose UDF nhanh hơn hàm Transpose (Application WorksheetFunction), kỹ thuật sao chép bộ nhớ tương đương xử lý chuỗi ở trên.
Giải thuật là sao chép bộ nhớ với kiểu lưu trữ là Variant (8 byte 32/16 byte 64), tạo một mảng bộ nhớ giả lập, gán lại mảng ban đầu, sau đó thay đổi chiều của vùng nhớ mảng .
Giải thuật này tốn kém thêm 2 lần bộ nhớ mảng đầu vào, nhưng đánh đổi lại là tốc độ.
JavaScript:
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" (Destination As Any, ByVal Length As LongPtr)
#Else
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" (Destination As Any, ByVal Length As Long)
#End If
#If VBA7 = 0 Then
Private Enum LongPtr:[_]:End Enum
#End If
Private Const nullptr As LongPtr = 0
#If Win64 Then
Private Const PTR_SIZE& = 8
Private Const VAR_SIZE& = 24
#Else
Private Const PTR_SIZE& = 4
Private Const VAR_SIZE& = 16
#End If
Private Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type
Private Type SAFEARRAY
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As LongPtr
rgsabound(1 To 2) As SAFEARRAYBOUND
End Type
Private Type mmVar
b(1 To VAR_SIZE) As Byte
End Type
Function ArrayTranspose(ByRef srcArray As Variant, Optional rowBase1 As Integer = -1, Optional columnBase1 As Integer = -1) As Boolean
If Not IsArray(srcArray) Then Exit Function
Dim p As LongPtr, pA As LongPtr, Pb As LongPtr, pSA As LongPtr, t As LongPtr
Dim s As SAFEARRAY, bo As SAFEARRAYBOUND, a() As mmVar, b() As mmVar
Dim r&, c&, j3&, l1&, l2&, u1&, u2&
pSA = VarPtr(srcArray) + PTR_SIZE: CopyMemory pSA, ByVal pSA, PTR_SIZE: CopyMemory s, ByVal pSA, LenB(s)
If s.pvData = 0 Then Exit Function
With s
Select Case .cDims
Case 2: With .rgsabound(2): l1 = .lLbound: u1 = .cElements + l1 - 1: End With
End Select
With .rgsabound(1): l2 = .lLbound: u2 = .cElements + l2 - 1: End With
End With
Select Case s.cDims
Case 1
t = (u2 - l2 + 1) * VAR_SIZE
ReDim arr(l2 To u2, 1 To 1)
p = VarPtr(srcArray(l2)): pA = VarPtr(arr(l2, 1))
CopyMemory ByVal pA, ByVal p, t
ZeroMemory ByVal p, t
srcArray = arr
Case 2:
t = (u1 - l1 + 1) * (u2 - l2 + 1) * VAR_SIZE
ReDim a(l1 To u1, l2 To u2): ReDim b(l2 To u2, l1 To u1)
' lâìy con troÒ tõìi dýÞ liêòu maÒng
p = VarPtr(srcArray(l1, l2)): pA = VarPtr(a(l1, l2)): Pb = VarPtr(b(l2, l1))
' Sao chép nôòi dung cuÒa maÒng src sang a 1 và lýu maÒng ðaÞ chuyêÒn ðôÒi vào b 1
CopyMemory ByVal pA, ByVal p, t
For r = l1 To u1: For c = l2 To u2: b(c, r) = a(r, c): Next c, r
' ghi các giá triò ðaÞ chuyêÒn ðôÒi trõÒ laòi maÒng src
CopyMemory ByVal p, ByVal Pb, t
' thay ðôÒi kích thýõìc cuÒa maÒng src trong câìu trúc safearray
With s
bo = .rgsabound(1): .rgsabound(1) = .rgsabound(2): .rgsabound(2) = bo
If rowBase1 > 0 Then .rgsabound(2).lLbound = rowBase1
If columnBase1 > 0 Then .rgsabound(1).lLbound = columnBase1
End With
CopyMemory ByVal pSA, s, LenB(s)
ZeroMemory ByVal Pb, t
End Select
ZeroMemory ByVal pA, t
ArrayTranspose = True
End FunctionLưu ý: Trong hàm ArrayTranspose tôi sử dụng vòng lặp For, để nhanh hơn nữa hãy tận dụng vòng lặp For Each.
XỬ LÝ MẢNG - ĐẢO, XOAY, CẮT
JavaScript:
Function ArrayRotate90(ByVal srcArray As Variant)
ArrayRotate90 = srcArray: ArrayCarveMM ArrayRotate90, 1, 1, 0
' Base Array: Transpose + FlipVertical:
' ------------------------ -------------------
' R1C1 R1C2 R1C3 R1C4 R1C5 R4C1 R3C1 R2C1 R1C1
' R2C1 R2C2 R2C3 R2C4 R2C5 R4C2 R3C2 R2C2 R1C2
' R3C1 R3C2 R3C3 R3C4 R3C5 R4C3 R3C3 R2C3 R1C3
' R4C1 R4C2 R4C3 R4C4 R4C5 R4C4 R3C4 R2C4 R1C4
' //////////////////////// R4C5 R3C5 R2C5 R1C5
' ///////////////////
End Function
Function ArrayRotate180(ByVal srcArray As Variant)
ArrayRotate180 = srcArray: ArrayCarveMM ArrayRotate180, 0, 1, 1
' Base Array: Flip:Vertical + Horizontal:
' ------------------------ ------------------------
' R1C1 R1C2 R1C3 R1C4 R1C5 R4C5 R4C4 R4C3 R4C2 R4C1
' R2C1 R2C2 R2C3 R2C4 R2C5 R3C5 R3C4 R3C3 R3C2 R3C1
' R3C1 R3C2 R3C3 R3C4 R3C5 R2C5 R2C4 R2C3 R2C2 R2C1
' R4C1 R4C2 R4C3 R4C4 R4C5 R1C5 R1C4 R1C3 R1C2 R1C1
' //////////////////////// ////////////////////////
End Function
Function ArrayRotate270(ByVal srcArray As Variant)
ArrayRotate270 = srcArray: ArrayCarveMM ArrayRotate270, 1, 0, 1
' Base Array: Transpose + FlipHorizontal:
' ------------------------ -------------------
' R1C1 R1C2 R1C3 R1C4 R1C5 R1C5 R2C5 R3C5 R4C5
' R2C1 R2C2 R2C3 R2C4 R2C5 R1C4 R2C4 R3C4 R4C4
' R3C1 R3C2 R3C3 R3C4 R3C5 R1C3 R2C3 R3C3 R4C3
' R4C1 R4C2 R4C3 R4C4 R4C5 R1C2 R2C2 R3C2 R4C2
' //////////////////////// R1C1 R2C1 R3C1 R4C1
' ///////////////////
End Function
Function ArrayCarveMM(ByRef srcArray As Variant, _
Optional ByVal transpose As Boolean = 0, _
Optional ByVal FlipVertical As Boolean = False, _
Optional ByVal FlipHorizontal As Boolean = False, _
Optional ByVal indexCutFirstRows As Long = -1, _
Optional ByVal indexCutFirstColumns As Long = -1, _
Optional ByVal indexCutLastRows As Long = -1, _
Optional ByVal indexCutLastColumns As Long = -1) As Boolean
If Not IsArray(srcArray) Then Exit Function
Dim p As LongPtr, pA As LongPtr, Pb As LongPtr, pSA As LongPtr, h As LongPtr, h2 As LongPtr
Dim s As SAFEARRAY, bo As SAFEARRAYBOUND, a() As mmVar, b() As mmVar
Dim r&, c&, j3&, l1&, l2&, u1&, u2&, i1%, i2%, IR&, IC&, tR&, tC&, F&(1), t&(1), y As Boolean
pSA = VarPtr(srcArray) + PTR_SIZE: CopyMemory pSA, ByVal pSA, PTR_SIZE: CopyMemory s, ByVal pSA, LenB(s)
If s.pvData = 0 Then Exit Function
With s
Select Case .cDims
Case 2: With .rgsabound(2): l1 = .lLbound: u1 = .cElements + l1 - 1: End With
End Select
With .rgsabound(1): l2 = .lLbound: u2 = .cElements + l2 - 1: End With
End With
Select Case s.cDims
Case 1
h = (u2 - l2 + 1) * VAR_SIZE
ReDim arr(l2 To u2, 1 To 1)
p = VarPtr(srcArray(l2)): pA = VarPtr(arr(l2, 1))
CopyMemory ByVal pA, ByVal p, h
ZeroMemory ByVal p, h
ZeroMemory ByVal pA, h
srcArray = arr
Case 2:
h = (u1 - l1 + 1) * (u2 - l2 + 1) * VAR_SIZE
ReDim a(l1 To u1, l2 To u2):
p = VarPtr(srcArray(l1, l2)): pA = VarPtr(a(l1, l2)):
CopyMemory ByVal pA, ByVal p, h
F(0) = l1: F(1) = l2
If indexCutFirstRows >= l1 And indexCutFirstRows < u1 Then IR = indexCutFirstRows + 1: y = True Else IR = l1
If indexCutLastRows > IR And indexCutLastRows <= u1 Then tR = indexCutLastRows - 1: y = True Else tR = u1
If indexCutFirstColumns >= l2 And indexCutFirstColumns < u2 Then IC = indexCutFirstColumns + 1: y = True Else IC = l2
If indexCutLastColumns > IC And indexCutLastColumns <= u2 Then tC = indexCutLastColumns - 1: y = True Else tC = u2
If transpose Then i1 = 1: y = True Else i2 = 1
t(0) = tR - IR + l1: t(1) = tC - IC + l2
h2 = (t(0) - F(0) + 1) * (t(1) - F(1) + 1) * VAR_SIZE
ReDim b(F(i1) To t(i1), F(i2) To t(i2))
If y Then
With s.rgsabound(2): .lLbound = F(i1): .cElements = t(i1) - F(i1) + 1: End With
With s.rgsabound(1): .lLbound = F(i2): .cElements = t(i2) - F(i2) + 1: End With
End If
Pb = VarPtr(b(F(i1), F(i2)))
' Sao chép nôòi dung cuÒa maÒng src sang a 1 và lýu maÒng ðaÞ chuyêÒn ðôÒi vào b 1
If FlipVertical Then
If FlipHorizontal Then
For r = IR To tR: F(0) = tR + IR - r: For c = IC To tC: F(1) = tC + IC - c: b(F(i1), F(i2)) = a(r, c): Next c, r
Else
For r = IR To tR: F(0) = tR + IR - r: For c = IC To tC: F(1) = c - IC + 1: b(F(i1), F(i2)) = a(r, c): Next c, r
End If
Else
If FlipHorizontal Then
For r = IR To tR: F(0) = r - IR + 1: For c = IC To tC: F(1) = tC + IC - c: b(F(i1), F(i2)) = a(r, c): Next c, r
Else
For r = IR To tR: F(0) = r - IR + 1: For c = IC To tC: F(1) = c - IC + 1: b(F(i1), F(i2)) = a(r, c): Next c, r
End If
End If
' ghi các giá triò ðaÞ chuyêÒn ðôÒi trõÒ laòi maÒng src
CopyMemory ByVal p, ByVal Pb, h2
' ' thay ðôÒi kích thýõìc cuÒa maÒng src trong câìu trúc safearray
If y Then CopyMemory ByVal pSA, ByVal VarPtr(s), LenB(s)
ZeroMemory ByVal Pb, h2
End Select
ZeroMemory ByVal pA, h
ArrayCarveMM = True
End Function
Lần chỉnh sửa cuối:
