ReDim Preserve для 1ой размерности ("строки") двумерного строкового массива

@Jack Famous · Регистрация: 10.05.2021

Студворк — интернет-сервис помощи студентам

Приветствую!
Эксперименты по мотивам этой темы.

Обрезка «строк» двумерного строкового массива. Только снизу. Нижняя граница = 1. Excel x64

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
58
59
60
61
62
63
64
65
66
67
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
' Based on (Testuser): https://www.cyberforum.ru/vba/thread3169815.html#post17322611
'==================================================================================================
Private Declare PtrSafe Sub API_MemPtr_Copy Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal ToVarPtr^, ByVal FromVarPtr^, ByVal Length^)
Private Declare PtrSafe Sub API_MemPtr_Zero Lib "kernel32.dll" Alias "RtlZeroMemory" (ByVal WhatVarPtr^, ByVal Size^)
Private Const vc_Mem_PtrSz^ = 8 ' — For Win64 Else 4
'==================================================================================================
'==================================================================================================
Sub PRDX_Arr2D_Str_CutRows(a2D_Out() As String, a2D_InDel() As String, rLast&)
Dim a$(), SzAdd^, VPo^, VPi^, c&
 
    ReDim a2D_Out(rLast, UBound(a2D_InDel, 2))
    SzAdd = rLast * vc_Mem_PtrSz
 
    For c = 1 To UBound(a2D_Out, 2)
        VPo = VarPtr(a2D_Out(1, c))
        VPi = VarPtr(a2D_InDel(1, c))
        API_MemPtr_Copy VPo, VPi, SzAdd
    Next c
 
    API_MemPtr_Zero VarPtr(a2D_InDel(1, 1)), vc_Mem_PtrSz * UBound(a2D_InDel, 1) * UBound(a2D_InDel, 2)
    Erase a2D_InDel
End Sub
'--------------------------------------------------------------------------------------------------
Private Sub Test_PRDX_Arr2D_Str_CutRows_Show()
Dim aIn$(), aOut$(), s$, r&, c&
 
    ReDim aIn(10, 3)
 
    For c = 1 To UBound(aIn, 2)
        For r = 1 To UBound(aIn, 1)
            aIn(r, c) = r & " • " & c
        Next r
    Next c
 
    PRDX_Arr2D_Str_CutRows aOut, aIn, 5
    
    For r = 1 To UBound(aOut, 1)
        For c = 1 To UBound(aOut, 2)
            s = s & " | " & aOut(r, c)
        Next c
    
        Debug.Print Mid$(s, 4): s = ""
    Next r
 
End Sub
'--------------------------------------------------------------------------------------------------
Private Sub Test_PRDX_Arr2D_Str_CutRows_Speed()
Dim aIn$(), aOut$(), t!, r&, c&
 
    t = Timer
        ReDim aIn(1000000, 100)    ' 1mln Rows
 
        For c = 1 To UBound(aIn, 2)
            For r = 1 To UBound(aIn, 1)
                aIn(r, c) = r & " • " & c
            Next r
        Next c
    Debug.Print Round(Timer - t, 2), "Fill" ' 42.52
 
    t = Timer
        PRDX_Arr2D_Str_CutRows aOut, aIn, 100000
    Debug.Print Round(Timer - t, 2), "Cut"  ' 0.16
End Sub

Непонятно, будет ли утечка памяти, если в "обрезаемом" In-массиве в "обрезаемой" (указатели которой мы не копировали) части есть строки …

@Jack Famous · 10.06.2024, 14:07 **[ТС]**

Сообщение от bedvit

Я так же как и Владимир, считаю, что работать с указателями нужно на том инструментарии, который для этого предназначен - в отдельных DLL, с обработкой ошибок и безопасного освобождения памяти.

мне вот что интересно в этой вашей с Владимиром позиции — откуда этой "любой ошибке" взяться?
Процедура (сейчас говорим про предыдущую тему с копирование массива в другой) просто делает всё, что нужно — корректно и безопасно.
Откуда тут ошибке взяться?

UPD:

Обновлённая процедура из шапки с новыми тестами

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
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
' Based on (Testuser): https://www.cyberforum.ru/vba/thread3169815.html#post17322611
'==================================================================================================
Private Declare PtrSafe Sub API_MemPtr_Copy Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal ToVarPtr^, ByVal FromVarPtr^, ByVal Length^)
Private Declare PtrSafe Sub API_MemPtr_Zero Lib "kernel32.dll" Alias "RtlZeroMemory" (ByVal WhatVarPtr^, ByVal Size^)
Private Const vc_Mem_PtrSz^ = 8 ' — For Win64 Else 4
'==================================================================================================
Sub PRDX_Arr2D_Str_CutRows(a2D_Out() As String, a2D_InDel() As String, rLast&, Optional CutPartIsEmpty As Boolean)
Dim a$(), SzAdd^, SzClear^, rCut&, rD&, UBr&, c&, UBc&, p&
 
    UBr = UBound(a2D_InDel, 1)
    UBc = UBound(a2D_InDel, 2)
    ReDim a2D_Out(rLast, UBc)
    SzAdd = rLast * vc_Mem_PtrSz
 
    If CutPartIsEmpty Then
        For c = 1 To UBc
            API_MemPtr_Copy VarPtr(a2D_Out(1, c)), VarPtr(a2D_InDel(1, c)), SzAdd
        Next c
    Else
        rCut = UBr - rLast  ' Count of DelRows in One Col
        ReDim a(rCut * UBc) ' ArrTrash
        SzClear = rCut * vc_Mem_PtrSz
        rD = rLast + 1: p = 1
 
        For c = 1 To UBc
            API_MemPtr_Copy VarPtr(a2D_Out(1, c)), VarPtr(a2D_InDel(1, c)), SzAdd
            API_MemPtr_Copy VarPtr(a(p)), VarPtr(a2D_InDel(rD, c)), SzClear
            p = p + rCut
        Next c
    End If
 
    API_MemPtr_Zero VarPtr(a2D_InDel(1, 1)), vc_Mem_PtrSz * UBr * UBc   ' Clear All Pointers
    Erase a2D_InDel
End Sub
'==================================================================================================
Sub PRDX_Arr2D_Str_CutRows_Simple(a2D_Out() As String, a2D_In() As String, rLast&)
Dim rCut&, r&, c&, UBc&
 
    UBc = UBound(a2D_In, 2)
    ReDim a2D_Out(rLast, UBc)
 
    For c = 1 To UBc
        For r = 1 To rLast
            a2D_Out(r, c) = a2D_In(r, c)
        Next r
    Next c
 
    'Erase a2D_In ' Optional for Test
End Sub
'--------------------------------------------------------------------------------------------------
Private Sub Test_PRDX_Arr2D_Str_CutRows_CutWithData()
Dim aIn$(), aOut$(), t!, r&, rLim&, c&
 
    t = Timer
        ReDim aIn(100000, 100) ' 100k Rows
 
        For c = 1 To UBound(aIn, 2)
            For r = 1 To UBound(aIn, 1)
                aIn(r, c) = r & " • " & c
            Next r
        Next c
    Debug.Print Round(Timer - t, 2), "Fill"             ' 4.3
 
    rLim = UBound(aIn, 1) / 2
 
    t = Timer
'        PRDX_Arr2D_Str_CutRows aOut, aIn, rLim         ' 8.3
'        PRDX_Arr2D_Str_CutRows_Simple aOut, aIn, rLim  ' 0.9 (16.3 with Erase a2D_In)
    Debug.Print Round(Timer - t, 2), "Cut"
End Sub
'--------------------------------------------------------------------------------------------------
Private Sub Test_PRDX_Arr2D_Str_CutRows_CutNoData()
Dim aIn$(), aOut$(), t!, r&, c&
Const rLim& = 500000
 
    t = Timer
        ReDim aIn(1000000, 100)    ' 1mln Rows
 
        For c = 1 To UBound(aIn, 2)
            For r = 1 To rLim
                aIn(r, c) = r & " • " & c
            Next r
        Next c
    Debug.Print Round(Timer - t, 2), "Fill" ' 21.5
 
    t = Timer
        PRDX_Arr2D_Str_CutRows aOut, aIn, rLim, True
    Debug.Print Round(Timer - t, 2), "Cut"  ' 0.2
End Sub
'==================================================================================================
'==================================================================================================
'==================================================================================================

Друзья, напишите, пожалуйста, примеры, как сменить размерность строкового массива (нужно, чтобы протестировать вариант без создания буферного массива):
     • одномерного. (0 To 19) → (1 To 20)
     • одномерного в двумерный столбец. (0 To 19) → (1 To 20, 1 To 1)
     • одномерного в двумерную строку. (0 To 19) → (1 To 1, 1 To 20)
     • двумерного. (0 To 19, 0 To 1) → (1 To 20, 1 To 2)

UPD2:

Версия V2 (без мусорного массива) работает пошустрее

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
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
' Based on (Testuser): https://www.cyberforum.ru/vba/thread3169815.html#post17322611
'==================================================================================================
Private Declare PtrSafe Sub API_MemPtr_Copy Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal ToVarPtr^, ByVal FromVarPtr^, ByVal Length^)
Private Declare PtrSafe Sub API_MemPtr_Zero Lib "kernel32.dll" Alias "RtlZeroMemory" (ByVal WhatVarPtr^, ByVal Size^)
Private Const vc_Mem_PtrSz^ = 8 ' — For Win64 Else 4
'==================================================================================================
Sub PRDX_Arr2D_Str_CutRows(a2D_Out() As String, a2D_InDel() As String, rLast&, Optional CutPartIsEmpty As Boolean)
Dim a$(), SzAdd^, SzClear^, rCut&, rD&, UBr&, c&, UBc&, p&
 
    UBr = UBound(a2D_InDel, 1)
    UBc = UBound(a2D_InDel, 2)
    ReDim a2D_Out(rLast, UBc)
    SzAdd = rLast * vc_Mem_PtrSz
 
    If CutPartIsEmpty Then
        For c = 1 To UBc
            API_MemPtr_Copy VarPtr(a2D_Out(1, c)), VarPtr(a2D_InDel(1, c)), SzAdd
        Next c
    Else
        rCut = UBr - rLast  ' Count of DelRows in One Col
        ReDim a(rCut * UBc) ' ArrTrash
        SzClear = rCut * vc_Mem_PtrSz
        rD = rLast + 1: p = 1
 
        For c = 1 To UBc
            API_MemPtr_Copy VarPtr(a2D_Out(1, c)), VarPtr(a2D_InDel(1, c)), SzAdd
            API_MemPtr_Copy VarPtr(a(p)), VarPtr(a2D_InDel(rD, c)), SzClear
            p = p + rCut
        Next c
    End If
 
    API_MemPtr_Zero VarPtr(a2D_InDel(1, 1)), vc_Mem_PtrSz * UBr * UBc   ' Clear All Pointers
    Erase a2D_InDel
End Sub
'==================================================================================================
Sub PRDX_Arr2D_Str_CutRows_V2(a2D_Out() As String, a2D_InDel() As String, rLast&, Optional CutPartIsEmpty As Boolean)
Dim SzAdd^, VPa^, UBr&, c&, UBc&
 
    UBr = UBound(a2D_InDel, 1)
    UBc = UBound(a2D_InDel, 2)
    ReDim a2D_Out(rLast, UBc)
    SzAdd = rLast * vc_Mem_PtrSz
 
    If CutPartIsEmpty Then
        For c = 1 To UBc
            API_MemPtr_Copy VarPtr(a2D_Out(1, c)), VarPtr(a2D_InDel(1, c)), SzAdd
        Next c
 
        API_MemPtr_Zero VarPtr(a2D_InDel(1, 1)), vc_Mem_PtrSz * UBr * UBc   ' Clear All Pointers
    Else
        For c = 1 To UBc
            VPa = VarPtr(a2D_InDel(1, c))
            API_MemPtr_Copy VarPtr(a2D_Out(1, c)), VPa, SzAdd
            API_MemPtr_Zero VPa, SzAdd
        Next c
    End If
 
    Erase a2D_InDel
End Sub
'==================================================================================================
Sub PRDX_Arr2D_Str_CutRows_Simple(a2D_Out() As String, a2D_In() As String, rLast&)
Dim rCut&, r&, c&, UBc&
 
    UBc = UBound(a2D_In, 2)
    ReDim a2D_Out(rLast, UBc)
 
    For c = 1 To UBc
        For r = 1 To rLast
            a2D_Out(r, c) = a2D_In(r, c)
        Next r
    Next c
 
'    Erase a2D_In    ' Optional for Test
End Sub
'--------------------------------------------------------------------------------------------------
Private Sub Test_PRDX_Arr2D_Str_CutRows_CutWithData()
Dim aIn$(), aOut$(), t!, r&, rLim&, c&
 
    t = Timer
        ReDim aIn(100000, 100) ' 100k Rows
 
        For c = 1 To UBound(aIn, 2)
            For r = 1 To UBound(aIn, 1)
                aIn(r, c) = r & " • " & c
            Next r
        Next c
    Debug.Print Round(Timer - t, 2), "Fill"             ' 4.3
 
    rLim = UBound(aIn, 1) / 2
 
    t = Timer
'        PRDX_Arr2D_Str_CutRows_V2 aOut, aIn, rLim      ' 7.7
'        PRDX_Arr2D_Str_CutRows aOut, aIn, rLim         ' 8.3
'        PRDX_Arr2D_Str_CutRows_Simple aOut, aIn, rLim  ' 0.9 (16.3 with Erase a2D_In)
    Debug.Print Round(Timer - t, 2), "Cut"
End Sub
'--------------------------------------------------------------------------------------------------
Private Sub Test_PRDX_Arr2D_Str_CutRows_CutNoData()
Dim aIn$(), aOut$(), t!, r&, c&
Const rLim& = 500000
 
    t = Timer
        ReDim aIn(1000000, 100)    ' 1mln Rows
 
        For c = 1 To UBound(aIn, 2)
            For r = 1 To rLim
                aIn(r, c) = r & " • " & c
            Next r
        Next c
    Debug.Print Round(Timer - t, 2), "Fill"                 ' 21.5
 
    t = Timer
'        PRDX_Arr2D_Str_CutRows_V2 aOut, aIn, rLim, True    ' 0.2
'        PRDX_Arr2D_Str_CutRows aOut, aIn, rLim, True       ' 0.2
    Debug.Print Round(Timer - t, 2), "Cut"
End Sub
'==================================================================================================
'==================================================================================================
'==================================================================================================

@testuser2 · 10.06.2024, 14:48

Сообщение от bedvit

только забыли добавить, что при любой ошибке

Да можно много еще чего добавить, только зачем человека грузить информацией, ведь тема указателей сама по себе в сущности не такая простая. Можно добавить, что в vba можно обрабатывать ошибки, что vba возможны некоторые варианты безопасных указателей (которые не нужно освобождать) и т.д. много чего. Единственно с чем соглашусь, что наверное не стоит такие темы открывать в разделе vba, чтоб не пугать народ фсякой фигней про указатели, а лучше в разделе vb6 там это нормально )

@Jack Famous · 10.06.2024, 17:50 **[ТС]**

Сообщение от testuser2

наверное не стоит такие темы открывать в разделе vba, чтоб не пугать народ фсякой фигней про указатели, а лучше в разделе vb6 там это нормально

ну, я же не знаю различий между VB6 и VBA

Да и инструменты мне именно для VBA нужны.

UPD:

Сообщение от Jack Famous

Друзья, напишите, пожалуйста, примеры, как сменить размерность строкового массива

создал новую тему для отдельного обсуждения

@Jack Famous · 14.06.2024, 13:46 **[ТС]**

Так намного лучше

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
Sub PRDX_Arr2D_Str_CutRows(aStr() As String, rLast&)
Dim a$(), sz^, c&, UBr&, UBc&
 
    UBr = UBound(aStr, 1)
    UBc = UBound(aStr, 2)
    ReDim a(rLast, UBc)
    sz = rLast * vc_Mem_PtrSz
 
    For c = 1 To UBc
        API_MemPtr_Copy VarPtr(a(1, c)), VarPtr(aStr(1, c)), sz
    Next c
 
    API_MemPtr_Zero VarPtr(aStr(1, 1)), UBr * UBc * vc_Mem_PtrSz
    ReDim aStr(rLast, UBc)
 
    For c = 1 To UBc
        API_MemPtr_Copy VarPtr(aStr(1, c)), VarPtr(a(1, c)), sz
    Next c
 
    API_MemPtr_Zero VarPtr(a(1, 1)), rLast * UBc * vc_Mem_PtrSz
End Sub
'==================================================================================================
Private Sub Test_PRDX_Arr2D_Str_CutRows()
Dim a$(), t!, r&, rLim&, c&
 
    t = Timer
        ReDim a(100000, 100)   ' 100k Rows
 
        For c = 1 To UBound(a, 2)
            For r = 1 To UBound(a, 1)
                a(r, c) = "TestString_UnShortAndBeauty_" & (r & "/" & c)
            Next r
        Next c
    Debug.Print Round(Timer - t, 2), "Fill" ' 3.3
 
    rLim = UBound(a, 1) / 2
 
    t = Timer
        PRDX_Arr2D_Str_CutRows a, rLim      ' 0.03
    Debug.Print Round(Timer - t, 2), "Cut", LBound(a, 1), UBound(a, 1), LBound(a, 2), UBound(a, 2)  ' 1  50000  1  100
End Sub

@Jack Famous · 18.06.2024, 10:05 **[ТС]**

Возможна утечка памяти в коде выше. В 13ой строке мы обнуляем все указатели, из которых только [верхняя] ЧАСТЬ была скопирована во временный массив. После обнуления часть строк [указатели на которые не были скопированы] повисает в ОЗУ забытыми. Вернусь к этому позже.

@bedvit · 18.06.2024, 17:31

Сообщение от Jack Famous

мне вот что интересно в этой вашей с Владимиром позиции — откуда этой "любой ошибке" взяться?
Процедура (сейчас говорим про предыдущую тему с копирование массива в другой) просто делает всё, что нужно — корректно и безопасно.
Откуда тут ошибке взяться?

Сообщение от Jack Famous

Возможна утечка памяти в коде выше. В 13ой строке мы обнуляем все указатели, из которых только [верхняя] ЧАСТЬ была скопирована во временный массив. После обнуления часть строк [указатели на которые не были скопированы] повисает в ОЗУ забытыми. Вернусь к этому позже.

Вот сам себе и ответил. Это на простых алгоритмах, а подумай над сортировкой с выводом итогового массива или массива индексов, фильтрацией по массиву условий в наших задачах и т.д. Жонглирование указателями на VBA будет выглядеть эпично, с отстрелом всех конечностей поблизости.

Новые блоги и статьи Все статьи Все блоги /
JWT аутентификация в ASP.NET Core UnmanagedCoder 18.06.2025 Разрабатывая веб-приложения, я постоянно сталкиваюсь с дилеммой: как обеспечить надежную аутентификацию пользователей без ущерба для производительности и масштабируемости? Классические подходы на. . .	Краткий курс по С# aaLeXAA 18.06.2025 Здесь вы найдете все необходимые функции чтоб написать програму на C# Задание 1: КЛАСС FORM 1 public partial class Form1 : Form { Spisok listin = new Spisok(); . . .	50 самых полезных примеров кода Python для частых задач py-thonny 17.06.2025 Эффективность работы разработчика часто измеряется не количеством написаных строк, а скоростью решения задач. Готовые сниппеты значительно ускоряют разработку, помогают избежать типичных ошибок и. . .	C# и продвинутые приемы работы с БД stackOverflow 17.06.2025 Каждый . NET разработчик рано или поздно сталкивается с ситуацией, когда привычные методы работы с базами данных превращаются в источник бессонных ночей. Я сам неоднократно попадал в такие ситуации,. . .	Angular: Вопросы и ответы на собеседовании Reangularity 15.06.2025 Готовишься к техническому интервью по Angular? Я собрал самые распространенные вопросы, с которыми сталкиваются разработчики на собеседованиях в этом году. От базовых концепций до продвинутых. . .
Архитектура Onion в ASP.NET Core MVC stackOverflow 15.06.2025 Что такое эта "луковая" архитектура? Термин предложил Джеффри Палермо (Jeffrey Palermo) в 2008 году, и с тех пор подход только набирал обороты. Суть проста - представьте себе лук с его. . .	Unity 4D GameUnited 13.06.2025 Четырехмерное пространство. . . Звучит как что-то из научной фантастики, правда? Однако для меня, как разработчика со стажем в игровой индустрии, четвертое измерение давно перестало быть абстракцией из. . .	SSE (Server-Sent Events) в ASP.NET Core и .NET 10 UnmanagedCoder 13.06.2025 Кажется, Microsoft снова подкинула нам интересную фичу в новой версии фреймворка. Работая с превью . NET 10, я наткнулся на нативную поддержку Server-Sent Events (SSE) в ASP. NET Core Minimal APIs. Эта. . .	С днём независимости России! Hrethgir 13.06.2025 Решил побеседовать, с утра праздничного дня, с LM о завоеваниях. То что она написала о народе, представителем которого я являюсь сам сначала возмутило меня, но дальше только смешило. Это чисто. . .	Лето вокруг. kumehtar 13.06.2025 Лето вокруг. Наполненное бурями и ураганами событий. На фоне магии Жизни, священной и вечной, неумелой рукой человека рисуется панорама душевного непокоя. Странные серые краски проникают и. . .

@Jack Famous 927 / 360 / 43 Регистрация: 10.05.2021 Сообщений: 1,539 Записей в блоге: 10
	18.06.2024, 10:05 [ТС]
	Возможна утечка памяти в коде выше. В 13ой строке мы обнуляем все указатели, из которых только [верхняя] ЧАСТЬ была скопирована во временный массив. После обнуления часть строк [указатели на которые не были скопированы] повисает в ОЗУ забытыми. Вернусь к этому позже. 0