Приветствую!
Функция нужна для отчётов: Debug.Print, MsgBox или печать лога в текстовый файл, но "чтоб как таблица было".
Код
| Visual Basic | 1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
| Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Function PRDX_Arr2D_To1D_AlignmentStrings(a2D, Optional ByVal nSpaces& = 1) As String()
Dim aStr$(), aLen&(), aSps$()
Dim tx$, r&, c&, l&
ReDim aStr(UBound(a2D, 1))
ReDim aLen(UBound(a2D, 2))
For r = 1 To UBound(a2D, 1)
For c = 1 To UBound(a2D, 2)
a2D(r, c) = Trim$(a2D(r, c))
l = Len(a2D(r, c))
If l > aLen(c) Then aLen(c) = l
Next c
Next r
ReDim aSps(UBound(aLen))
For c = 1 To UBound(aLen)
aSps(c) = Space$(aLen(c) + nSpaces)
Next c
For r = 1 To UBound(a2D, 1)
For c = 1 To UBound(a2D, 2)
tx = aSps(c)
Mid$(tx, 1, Len(a2D(r, c))) = a2D(r, c)
aStr(r) = aStr(r) & tx
Next c
aStr(r) = Trim$(aStr(r))
Next r
PRDX_Arr2D_To1D_AlignmentStrings = aStr
End Function
'--------------------------------------------------------------------------------------------------
Private Sub Test_PRDX_Arr2D_To1D_AlignmentStrings()
Dim x
ReDim x(3, 3)
x(1, 1) = "My dream": x(1, 2) = "is": x(1, 3) = "to fly"
x(2, 1) = "Over": x(2, 2) = "the": x(2, 3) = "rainbow"
x(3, 1) = "So": x(3, 2) = "": x(3, 3) = "high"
Debug.Print Join(PRDX_Arr2D_To1D_AlignmentStrings(x, 3), vbLf)
End Sub |
|
UPD 26/01/2023:
Описание обновления
• Ускорил в 4 раза.
• Теперь можно использовать в качестве разделителя элементов любой символ или даже строку. До общей длины по столбцу элементы по прежнему "добиваются" пробелами. Можно и это сделать переменной, но практического смысла пока не вижу.
• Теперь функция возвращает длину [каждой] строки сцепки, а строковый массив для заполнения, нужно передать.
Код
| Visual Basic | 1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
| Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Function PRDX_Arr2D_To1D_AlignmentStrings(a2D, a1D_Res$(), Optional ByVal sepJoin$ = " ") As Long
Dim aLen&(), tx$, txSp$, r&, c&, l&, lSep&
ReDim a1D_Res(UBound(a2D, 1))
ReDim aLen(UBound(a2D, 2))
For c = 1 To UBound(a2D, 2)
For r = 1 To UBound(a2D, 1)
l = Len(a2D(r, c))
If l > aLen(c) Then aLen(c) = l
Next r
Next c
l = 0
For c = 1 To UBound(aLen)
l = l + aLen(c)
Next c
lSep = Len(sepJoin)
l = l + lSep * (UBound(aLen) - 1)
PRDX_Arr2D_To1D_AlignmentStrings = l
txSp = Space$(l): l = 0
For r = 1 To UBound(a2D, 1)
tx = txSp
For c = 1 To UBound(a2D, 2) - 1
Mid$(tx, l + 1, aLen(c)) = a2D(r, c): l = l + aLen(c)
Mid$(tx, l + 1, lSep) = sepJoin: l = l + lSep
Next c
Mid$(tx, l + 1, aLen(c)) = a2D(r, c)
a1D_Res(r) = tx: l = 0
Next r
End Function
'--------------------------------------------------------------------------------------------------
Private Sub TestSpeed_PRDX_Arr2D_To1D_AlignmentStrings()
Dim bef$(), aft$()
Dim t!, n&, l&
Const nCyc& = 1000000
ReDim bef(3, 3)
bef(1, 1) = "My dream": bef(1, 2) = "is": bef(1, 3) = "to fly"
bef(2, 1) = "Over": bef(2, 2) = "the": bef(2, 3) = "rainbow"
bef(3, 1) = "So": bef(3, 2) = "": bef(3, 3) = "high"
t = Timer
For n = 1 To nCyc
l = PRDX_Arr2D_To1D_AlignmentStrings(bef, aft, " — ") ' 3.23
Next n
Debug.Print Format$(Timer - t, "0.00"), l
Debug.Print Join(aft, vbLf)
End Sub |
|
|
Привет!
Сообщение от SergioJek
Сообщение от SergioJek
