Преобразование типов для копирования определенных ячеек из одного столбца в массив

@mr sinister · Регистрация: 28.01.2014

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

Доброго времени суток.
Есть таблица в экселе. Цель - скопировать определенные ячейки из одного столбца в массив, затем вывести содержимое массива на другой лист.
Первый же вопрос. Значение из ячейки я беру используя

Visual Basic
1
2
3
Range("D14").Select
Dim curr As Long
curr = ActiveCell.FormulaR1C1

И с этим все в порядке.
Далее я сдвигаю выбор на одну ячейку вниз и пытаюсь произвести вычитание.

Visual Basic
1
2
ActiveCell.Offset(1, 0).Select
If ActiveCell.FormulaR1C1 - curr <> 1 Then

Так вот, когда я пытаюсь либо сравнить результат следующей разности с 1, либо просто присвоить этот результат другой переменной типа long, возникает ошибка 13, то бишь несоответствие типов, хотя строкой выше значение FormulaR1C1 прекрасно присваивалось переменной типа Long.
Кастование (CLng()) тоже не помогает.
Помогите, пожалуйста.

P.S. вот весь кхм,

код

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
Sub bracket()
Range("D14").Select
Dim curr As Long
Dim i As Integer
Dim skip As Boolean
Dim result() As Long
i = 0
Do
    curr = ActiveCell.FormulaR1C1
    ActiveCell.Offset(1, 0).Select
    If ActiveCell.FormulaR1C1 - curr <> 1 Then
    i = i + 1
    End If
Loop While Not IsEmpty(ActiveCell)
ReDim result(i)
Range("D14").Select
skip = False
i = 0
Do
    curr = ActiveCell.FormulaR1C1
    If skip = False Then
        result(i) = curr
    End If
    ActiveCell.Offset(1, 0).Select
    If ActiveCell.FormulaR1C1 - curr <> 1 Then
    result(i) = curr
    i = i + 1
    Else: skip = True
    End If
Loop While Not IsEmpty(ActiveCell)
 
MsgBox result(1)
End Sub

, в том состоянии в котором он есть, если это может что-либо прояснить

@Alex77755 · 02.02.2014, 08:42

.exists самая главная фишка словаря! позволяет сразу определиь наличие ключа в словаре.
Без перебора всех элементоов

@Hugo121 · 02.02.2014, 12:04

Магии там нет. Как и формально нет сортировки.
Цикл по листам, с каждого берём данные в массив.
Цикл по массиву - заносим в словарь номера, сразу определяем максимальный и минимальный номер.
Когда всё собрано - цикл от минимума к максимуму, смотрим есть ли номер в словаре - формируем массив результатов.
Сперва делал с одним флагом - но тогда получалось много лишних операций с "хвостом" группы, он всё время перезаписывался в массиве, что неправильно (хотя никому это и не видно

). Поэтому два флага.

Если нужно каждый документ писать в свой столбец - думаю нужно ориентироваться на слово "Номер" - добавить ещё флаг или два и писать каждую группу в свой массив (он и так изначально создан по факту с запасом, ну будет с огромным запасом...).
Хотя можно собирать без запаса в коллекцию, потом при выводе перекладывать - но думаю это лишние сложности.
И тогда создать книгу для результатов думаю нужно сразу после сбора номеров, чтоб было куда выгружать эти многие массивы.

Но вот не понял такие Ваши результаты:

Visual Basic
1
2
3
4
5
85245   85287   43
85288   85325   38
 
86433   86439   7
86440   86442   3

Вот почему тут группы разбиваются? Это ведь один документ, только листы поменялись. Я думаю так не нужно делать.
Но можно конечно если нужно - всего лишь ещё два флага и путаницы добавить

@mr sinister · 05.02.2014, 09:59 **[ТС]**

Hugo121, я в отчаянии. Я уже второй день

об обработку этого массива, и все, на что у меня остались силы, это испустить предсмертный вздох о помощи.
Пути два:
1. В оригинале, записав начало серии, я с помощью Offset переходил к следующему элементу. Объясните мне, пожалуйста, как можно в рамках цикла For Each повторить этот трюк (Каким образом записывать=>обрабатывать предыдущий элемент или каким образом достать следующий?)
Вот собственно, сам

Цикл

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
Sub tt()
    Dim sh As Object
    Dim a(), el
    Dim first As Boolean, s As Boolean, s2 As Boolean, skip As Boolean
    Dim i As Integer
    Dim kassa(1024) As Long, serg(1024) As Long
    
    first = True
    s = False
    s2 = False
    skip = False
    i = 0
    prev = 0
 
        For Each sh In Worksheets
            If sh.UsedRange.Columns.Count > 3 Then
                a = sh.UsedRange.Columns(4).Value
                For Each el In a
                    'first series
                    If (s = True) And (s2 = False) Then
                        If (el <> 0) And (IsNumeric(el)) Then
                            If skip = False Then
                                kassa(i) = el
                                i = i + 1
                            End If
                            If i <> 0 Then
                                If el - kassa(i - 1) <> 1 Then
                                    kassa(i) = el
                                    i = i + 1
                                    kassa(i) = kassa(i - 1) - kassa(i - 2) + 1
                                    i = i + 1
                                    skip = False
                                Else:
                                    skip = True
                                End If
                            End If
                        Else:
                            s = False
                            kassa(i) = kassa(i - 1) - kassa(i - 2) + 1
                        End If
                    End If
                    'second series
                    If s2 = True Then
                        If (el <> 0) And (IsNumeric(el)) Then
                            If skip = False Then
                                serg(i) = el
                                i = i + 1
                            End If
                            If i <> 0 Then
                                If el - serg(i - 1) <> 1 Then
                                    serg(i) = el
                                    i = i + 1
                                    serg(i) = serg(i - 1) - serg(i - 2) + 1
                                    i = i + 1
                                    skip = False
                                Else:
                                    skip = True
                                End If
                            End If
                        Else:
                            s2 = False
                            serg(i) = serg(i - 1) - serg(i - 2) + 1
                        End If
                    End If
                    'series beginning trigger
                    If el = "Iiia?" Then
                        If first = True Then
                            s = True
                            first = False
                        Else:
                            s2 = True
                            i = 0
                            skip = False
                        End If
                    End If
                    
                Next
            End If
        Next
 
Dim gen As Worksheet
Set gen = Sheets.Add(After:=Sheets(Worksheets.Count))
Worksheets(Worksheets.Count).Activate
Range("A1").Select
Dim j As Integer
Dim trio As Integer
trio = 1
For Each el In kassa
    If el <> 0 Then
        ActiveCell.Value = el
        ActiveCell.Offset(0, 1).Select
        Select Case trio
        Case 1
        trio = 2
        Case 2
        trio = 3
        Case 3
        trio = 1
        ActiveCell.Offset(1, -3).Select
        End Select
    End If
Next
 
Range("E1").Select
trio = 1
For Each el In serg
    If el <> 0 Then
        ActiveCell.Value = el
        ActiveCell.Offset(0, 1).Select
        Select Case trio
        Case 1
        trio = 2
        Case 2
        trio = 3
        Case 3
        trio = 1
        ActiveCell.Offset(1, -3).Select
        End Select
    End If
Next
MsgBox "ok"
 
End Sub

, но он выводит все по одному (я как раз таки серии не отслеживаю)

2. В итоге я решил избавиться от For цикла, чтобы, используя Do While, обращаться в любой момент к любым элементам. Я урезал тело вашего For Each до одной строки (l = l + 1). Объясните мне, пожалуйста, почему:
- массив а двумерный, по два элемента в каждой строчке и второй всегда равен 1
- при попытке обращения к нему вне этого самого цикла For Each весь массив оказывается пуст
Вот собственно, сам

Цикл

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
124
125
126
127
128
Sub tt()
    Dim sh As Object
    Dim a()
    Dim first As Boolean, s As Boolean, s2 As Boolean, skip As Boolean
    Dim i As Integer, l As Integer, j As Integer
    Dim kassa(1024) As Long, serg(1024) As Long
    Dim curr As Long
    
    first = True
    s = False
    s2 = False
    skip = False
    i = 0
    l = 0
    j = 1
 
For Each sh In Worksheets
    If sh.UsedRange.Columns.Count > 3 Then
        a = sh.UsedRange.Columns(4).Value
        For Each el In a
            l = l + 1
        Next
    End If
Next
 
Do
    'first series
    If (s = True) And (s2 = False) Then
        If (a(j, 1) <> 0) And (IsNumeric(a(j, 1))) Then
            curr = a(j, 1)
            If skip = False Then
                kassa(i) = curr
                i = i + 1
            End If
            j = j + 1
            If a(j, 1) - curr <> 1 Then
                kassa(i) = curr
                i = i + 1
                kassa(i) = kassa(i - 1) - kassa(i - 2) + 1
                i = i + 1
                skip = False
            Else:
                skip = True
            End If
        Else:
            s = False
            kassa(i) = kassa(i - 1) - kassa(i - 2) + 1
        End If
    End If
    'second series
    If s2 = True Then
        If (a(j, 1) <> 0) And (IsNumeric(a(j, 1))) Then
            curr = a(j, 1)
            If skip = False Then
                serg(i) = curr
                i = i + 1
            End If
            j = j + 1
            If a(j, 1) - serg(i - 1) <> 1 Then
                serg(i) = curr
                i = i + 1
                serg(i) = serg(i - 1) - serg(i - 2) + 1
                i = i + 1
                skip = False
            Else:
                skip = True
            End If
        Else:
            s2 = False
            serg(i) = serg(i - 1) - serg(i - 2) + 1
        End If
    End If
    'series beginning trigger
    If a(j, 1) = "Íîìåð" Then
        If first = True Then
            s = True
            first = False
        Else:
            s2 = True
            i = 0
            skip = False
        End If
    End If
    j = j + 1
Loop While j <= l
 
Dim gen As Worksheet
Set gen = Sheets.Add(After:=Sheets(Worksheets.Count))
Worksheets(Worksheets.Count).Activate
Range("A1").Select
Dim trio As Integer
trio = 1
For Each el In kassa
    If el <> 0 Then
        ActiveCell.Value = el
        ActiveCell.Offset(0, 1).Select
        Select Case trio
        Case 1
        trio = 2
        Case 2
        trio = 3
        Case 3
        trio = 1
        ActiveCell.Offset(1, -3).Select
        End Select
    End If
Next
 
Range("E1").Select
trio = 1
For Each el In serg
    If el <> 0 Then
        ActiveCell.Value = el
        ActiveCell.Offset(0, 1).Select
        Select Case trio
        Case 1
        trio = 2
        Case 2
        trio = 3
        Case 3
        trio = 1
        ActiveCell.Offset(1, -3).Select
        End Select
    End If
Next
MsgBox "ok"
 
End Sub

, но он при первом же обращении к массиву говорит "Subscript out of range"

П. С. Я писал уже насчет "таких моих результатов", но повторюсь. Отчетности это не портит. Красивее без этого, но это не критично. Возникает из-за того, что проверка, не кончились ли значения на странице, стоит после проверки на окончание серии. У вас не возникает, потому что у вас сразу все страницы в массиве, вы не переходите с одной на другую.

Добавлено через 40 минут

Не по теме:

Сообщение от Апострофф

Причина: Не давайте ссылок на потусторонние ресурсы, читайте правила-https://www.cyberforum.ru/announcement.php?a=3

Кликните здесь для просмотра всего текста

Я только что трижды перечитал все запреты форума, и я под них не попадаю.
Это не ссылка рекламного характера, в ней нет ничего вредоносного, ничего нарушающего авторские права, ничего пропагандирующего другие форумы, ничего оскорбляющего других пользователей, ничего нарушающего законодательство РФ.
Ни слова про "потусторонние ресурсы" я в правилах не нашел.

@Апострофф · 05.02.2014, 10:11

Комментарий модератора

Сообщение от правила

4.12. Картинки и любые другие файлы загружайте на форум, во избежание их удаления или потери на сторонних ресурсах.
5.18. Запрещено размещать задания и решения в виде картинок и других файлов с их текстом.
6.5. Запрещено публично обсуждать действия администрации форума, касающиеся их прямых обязанностей.

Этого достаточно?

@Hugo121 · 05.02.2014, 11:03

1.в рамках цикла For Each перейти к предыдущему элементу не получится. Используйте цикл for n to m.

2. Вот тут

Visual Basic
1
2
3
4
5
6
7
8
For Each sh In Worksheets
    If sh.UsedRange.Columns.Count > 3 Then
        a = sh.UsedRange.Columns(4).Value
        For Each el In a
            l = l + 1
        Next
    End If
Next

Вы всего лишь подсчитываете общее количество строк всех UsedRange. Это можно сделать проще и намного быстрее:

Visual Basic
1
2
3
4
5
For Each sh In Worksheets
    If sh.UsedRange.Columns.Count > 3 Then
            l = l + sh.UsedRange.rows.count
    End If
Next

Но зачем нужно это количество? Да и это не количество строк с данными, а общее количество строк, многие из которых пустые.

"почему:
- массив а двумерный, по два элемента в каждой строчке и второй всегда равен 1" - потому что это массив из одного столбца, где у каждого элемента есть номер строки и номер столбца, и столбец этот только первый!

"почему:
- при попытке обращения к нему вне этого самого цикла For Each весь массив оказывается пуст" - это нужно смотреть в файле. Судя по коду - это будет, если в последнем листе 4-й столбец использованного диапазона будет пуст.

"при первом же обращении к массиву говорит "Subscript out of range"" - нужно смотреть на деле какой там в этот момент массив и куда Вы смотрите.

Вообще в Ваши коды не вникал, т.к. я всё делал иначе. И даже что-то начал делать чтоб отследить эти разные документы - но это было давно (3 дня прошло, и было написано много других кодов - детали того уже не помню) и не тут...
Т.е. сейчас той заготовки нет, она дома. А дома сегодня вечером заняться этой задачей времени не будет.

@mr sinister · 05.02.2014, 17:11 **[ТС]**

1. Перейти не получится. А нельзя ли как то хранить предыдущий элемент для его обработки в следующей итерации? Я над этим корчился-тужился, но так и не осилил.
2. Если использовать не For Each, а другие типы циклов, чтобы обращаться к любым элементам, то нужен собственно массив состоящий из всего 4 столбца РАБОЧЕЙ КНИГИ. Количество всех строк уже есть, осталось получить такой массив. Как?

@Hugo121 · 06.02.2014, 10:08

1. запоминайте в переменной значение или индекс (добавьте счётчик) - смотря что нужно.
2. в моём коде это есть:

Visual Basic
1
a = sh.UsedRange.Columns(4).Value

но не РАБОЧЕЙ КНИГИ, а текущего перебранного листа.
У книги нет столбцов.

Добавлено через 16 часов 31 минуту
Сделал обработку этих "дыр" в файле на основе предыдущего кода:

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
Option Explicit
 
Sub tt()
    Dim sh As Object
    Dim a(), el, ind&
    Dim mi As Long, ma As Long
    Dim dic As Object, wb As Object, outsh As Object
 
    mi = 1000000000#
    Set wb = ActiveWorkbook
    Set outsh = Workbooks.Add(1).Sheets(1)
    Set dic = CreateObject("scripting.dictionary")
    ind = 1
 
    For Each sh In wb.Worksheets
        If sh.UsedRange.Columns.Count > 3 Then
            a = sh.UsedRange.Columns(4).Value
            For Each el In a
                If Len(el) Then
                    If el = "Номер" Then
                        If mi <> 1000000000# Then
                            vivod dic, mi, ma, outsh, ind
                            mi = 1000000000#: ma = 0
                            Set dic = CreateObject("scripting.dictionary")
                        End If
                    End If
                    If IsNumeric(el) Then
                        dic.Item(Val(el)) = 0&
                        If mi > el Then mi = el
                        If ma < el Then ma = el
                    End If
                End If
            Next
        End If
    Next
 
    vivod dic, mi, ma, outsh, ind
 
End Sub
 
 
Private Sub vivod(sl, mi, ma, sh, ind)
    Dim i&, ii&, flagS As Boolean, flagF As Boolean
 
    ReDim a(1 To (ma - mi + 3) / 2, 1 To 3)
    ii = 1: flagS = True: flagF = True
 
    For i = mi To ma + 1
        If sl.exists(i) Then
            If flagS Then
                a(ii, 1) = i: flagS = False: flagF = True
            End If
        Else
            If flagF Then
                a(ii, 2) = i - 1: a(ii, 3) = a(ii, 2) - a(ii, 1) + 1
                flagS = True: flagF = False: ii = ii + 1
            End If
        End If
    Next
 
    sh.Cells(1, ind).Resize(ii - 1, 3) = a
    ind = ind + 4
 
End Sub

Далее можно добавить обработку всех выбранных файлов, если нужно.
Сложнее добавить кассиров к каждому результату -но тоже можно.

@mr sinister · 07.02.2014, 03:28 **[ТС]**

Hugo121, во-первых спасибо за доработанную версию. Во-вторых нет, кассиров стабильно двое. В-третьих, насчет файлов, это оно? Или можно проще, без центрального файла?

@Hugo121 · 07.02.2014, 10:52

Нет.
Т.к. у Вас там много таких файлов с билетами, а этот код обрабатывает только один активный файл (у меня код расположен в другом файле - это может быть и personal.xls как по ссылке, но у меня просто пустой файл-"инструмент" с этим кодом), то думаю есть смысл добавить в код последовательную обработку нескольких файлов с билетами.
Есть варианты:
обрабатываем не глядя все файлы определённой папки
обрабатываем не глядя все файлы выбранной в диалоге папки
обрабатываем все выбранные пользователем в диалоге файлы

Если файлов будет много - то думаю нужно доработать вывод собранного. Например вот получите Вы 40 таких парных столбцов, без привязки к файлам - их ведь дальше опять нужно вручную как-то обрабатывать...

@mr sinister · 11.02.2014, 06:47 **[ТС]**

Hugo121, конечно, обрабатываем все выбранные пользователем в диалоге файлы

@Hugo121 · 11.02.2014, 12:02

Ну почему же "конечно"? Первый вариант тоже часто применим, даже может чаще чем третий - вот понакидали Вам в папку свежих файлов, Вы нажали кнопку и все файлы обработали без лишних разговоров-диалогов.
Но ладно, третий вариант (добавил в результат вывод имени обрабатываемого файла):

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
Option Explicit
 
Dim tfilename$
 
Sub tt()
    Dim sh As Object, SelectedItem
    Dim a(), el, ind&
    Dim mi As Long, ma As Long
    Dim dic As Object, wb As Object, outsh As Object
 
    'вызываем диалог выбора файлов
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Выберите файлы отчетов"    'надпись в окне диалога
        'путь по умолчанию к папке где расположен исходный файл, можно изменить
        .InitialFileName = ThisWorkbook.Path & Application.PathSeparator & "*.xls*"
        .AllowMultiSelect = True    'выбор нескольких файлов разрешён
        If .Show = False Then Exit Sub
 
        Set outsh = Workbooks.Add(1).Sheets(1)
        ind = 1
 
        Application.ScreenUpdating = False
 
        For Each SelectedItem In .SelectedItems    'перебор файлов в папке
            tfilename = SelectedItem
            mi = 1000000000#: ma = 0
            Set dic = CreateObject("scripting.dictionary")
 
            Set wb = Workbooks.Open(SelectedItem)            'открываем книгу
            'операции с открытой книгой
            For Each sh In wb.Worksheets
                If sh.UsedRange.Columns.Count > 3 Then
                    a = sh.UsedRange.Columns(4).Value
                    For Each el In a
                        If Len(el) Then
                            If el = "Номер" Then
                                If mi <> 1000000000# Then
                                    vivod dic, mi, ma, outsh, ind
                                    mi = 1000000000#: ma = 0
                                    Set dic = CreateObject("scripting.dictionary")
                                End If
                            End If
                            If IsNumeric(el) Then
                                dic.Item(Val(el)) = 0&
                                If mi > el Then mi = el
                                If ma < el Then ma = el
                            End If
                        End If
                    Next
                End If
            Next
 
            wb.Close 0
            vivod dic, mi, ma, outsh, ind
 
        Next SelectedItem
    End With
 
    Application.ScreenUpdating = True
    Exit Sub
 
End Sub
 
 
Private Sub vivod(sl, mi, ma, sh, ind)
    Dim i&, ii&, flagS As Boolean, flagF As Boolean
 
    ReDim a(1 To (ma - mi + 3) / 2 + 1, 1 To 3)
    a(1, 1) = tfilename
    ii = 2: flagS = True: flagF = True
 
    For i = mi To ma + 1
        If sl.exists(i) Then
            If flagS Then
                a(ii, 1) = i: flagS = False: flagF = True
            End If
        Else
            If flagF Then
                a(ii, 2) = i - 1: a(ii, 3) = a(ii, 2) - a(ii, 1) + 1
                flagS = True: flagF = False: ii = ii + 1
            End If
        End If
    Next
 
    sh.Cells(1, ind).Resize(ii - 1, 3) = a
    ind = ind + 4
 
End Sub

@mr sinister · 14.02.2014, 21:13 **[ТС]**

Hugo121, лучше, если каждый кассир каждого дня сохраняется в подпапку текущей папки "import" в отдельный файл с маской дата + кассир.
Вот, я убрал ind и описал в комментариях, что должно происходить, поправьте меня, если я не вовремя пытаюсь сохранить результат или криво беру символы из строки

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
Option Explicit
 
Dim tfilename$
 
Sub tt()
    Dim sh As Object, SelectedItem
    Dim a(), el
    Dim mi As Long, ma As Long
    'для считывания даты, и копирования в имя файла
    dim day as string
    'кто текущий кассир; касса - истина; сергей - ложь
    dim k as boolean
    Dim dic As Object, wb As Object, outsh As Object
 
    'вызываем диалог выбора файлов
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Выберите файлы отчетов"    'надпись в окне диалога
        'путь по умолчанию к папке где расположен исходный файл, можно изменить
        .InitialFileName = ThisWorkbook.Path & Application.PathSeparator & "*.xls*"
        .AllowMultiSelect = True    'выбор нескольких файлов разрешён
        If .Show = False Then Exit Sub
 
        Set outsh = Workbooks.Add(1).Sheets(1)
 
        Application.ScreenUpdating = False
 
        For Each SelectedItem In .SelectedItems    'перебор файлов в папке
            tfilename = SelectedItem
            mi = 1000000000#: ma = 0
            Set dic = CreateObject("scripting.dictionary")
 
            Set wb = Workbooks.Open(SelectedItem)            'открываем книгу
            'операции с открытой книгой
            'set d = Cells(7,2)
            'day = d(0) + d(1) + d(3) + d(4) + d(8) + d(9)
            k = true
            For Each sh In wb.Worksheets
                If sh.UsedRange.Columns.Count > 3 Then
                    a = sh.UsedRange.Columns(4).Value
                    For Each el In a
                        If Len(el) Then
                            If el = "Номер" Then
                                If mi <> 1000000000# Then
                                    vivod dic, mi, ma, outsh
                                    'if k = true then day = day + 'k' else: day = day + 's'
                                    'сохранить... см. ниже
                                    mi = 1000000000#: ma = 0
                                    Set dic = CreateObject("scripting.dictionary")
                                End If
                            End If
                            If IsNumeric(el) Then
                                dic.Item(Val(el)) = 0&
                                If mi > el Then mi = el
                                If ma < el Then ma = el
                            End If
                        End If
                    Next
                End If
            Next
 
            wb.Close 0
            'if k = true then day = day + 'k' else: day = day + 's'
            'сохранить созданный лист в подпапку "import" исходной с названием "day"
            'outsh = Workbooks.Add(1).Sheets(1)
            vivod dic, mi, ma, outsh
            'сохранить... (см. выше)
        Next SelectedItem
    End With
 
    Application.ScreenUpdating = True
    Exit Sub
 
End Sub
 
 
Private Sub vivod(sl, mi, ma, sh)
    Dim i&, ii&, flagS As Boolean, flagF As Boolean
 
    ReDim a(1 To (ma - mi + 3) / 2 + 1, 1 To 3)
    a(1, 1) = tfilename
    ii = 2: flagS = True: flagF = True
 
    For i = mi To ma + 1
        If sl.exists(i) Then
            If flagS Then
                a(ii, 1) = i: flagS = False: flagF = True
            End If
        Else
            If flagF Then
                a(ii, 2) = i - 1: a(ii, 3) = a(ii, 2) - a(ii, 1) + 1
                flagS = True: flagF = False: ii = ii + 1
            End If
        End If
    Next
 
    sh.Cells(2, 1).Resize(ii - 1) = "Билет театральный рулонный (1 бил.=1 руб.)"
    sh.Cells(2, 2).Resize(ii - 1) = "ТЕ"
    sh.Cells(2, 3).Resize(ii - 1, 3) = a
    sh.Cells(1, 1).Resize(1, 5) = Array("БСО", "Серия БСО", "Начальный номер", "Конечный номер", "Количество")
 
End Sub

@Hugo121 · 14.02.2014, 22:14

Если убираете ind - значит нужно как-то иначе обрабатывать эти разные документы в одном файле.
Сейчас второй лепит данные на первый.
Но если в файле будет только один документ (и обрабатывать будете только один файл) - тогда вроде нормально, только чуть подправить эти новые столбцы - там вероятно не нужно тогда имя файла.
Ну и тогда

Visual Basic
1
.AllowMultiSelect = False    'выбор нескольких файлов не разрешён

и цикл по всем SelectedItem In .SelectedItems можно убрать. Ну или оставить...
Но нужен только .SelectedItems(1)

@mr sinister · 14.02.2014, 22:49 **[ТС]**

Hugo121, проясню - протестив на деле процесс импорта, я сделал вывод, что удобнее не разделять кассиров в одном отчете отступом на листе, а помещать их в разные рабочие книги, и, соответственно, сохранять эти две разных рабочих книги соответственно с постфиксами "k" и "s".

@Hugo121 · 14.02.2014, 23:19

Ну тогда можно брать сразу все файлы, новую книгу генерить в начале Sub vivod(), сохранять-закрывать её в конце Sub vivod()

@mr sinister · 14.02.2014, 23:27 **[ТС]**

Hugo121, проясните, пожалуйста:
1. Обращаться для сохранения к wb или к SelectedItem?
2. Какие собственно команды использовать, чтобы спуститься на уровень ниже в заданную папку (можно без On Error, папка 100% там будет) и сохранить текущую книгу с заданным именем?

@Hugo121 · 14.02.2014, 23:31

1. Ни так ни эдак - создайте Set outsh = Workbooks.Add(1).Sheets(1) внутри этого макроса, и там же сохраняйте-закрывайте.
2. Зачем на уровень ниже? Просто сохраняйте файл по полному пути - имя папки интегрируйте в путь.
Вопрос где брать имя кассира - в моём коде для этого нужно ещё один массив перебирать....

@mr sinister · 14.02.2014, 23:40 **[ТС]**

Hugo121, 1. Ясно-понятно.
2. Все отсортировано по месяцам, так что полный путь будет раз в месяц разный. Имя кассира знать не нужно и брать соответственно тоже. Просто в начале обработки файла к равно истине - первый кассир - касса. При следующем обнаружении слова "номер" к становится ложью, значит, кассир - сергей. С каждым новым фацлом сбрасывается. И да. Как собственно сохранять то этот outsh? Всмысле какой командой имя файла, путь задавать и прочее?

@Hugo121 · 14.02.2014, 23:51

Как сохранять - запишите нужный процесс рекордером, возьмите код.
Как вставить путь - разберётесь.
Ну а сам файл будет outsh.parent

@mr sinister · 16.02.2014, 04:09 **[ТС]**

Hugo121, печаль-беда.
Вот, нагуглил как все это делается, однако почему-то mi в нужный момент не сбрасывается до 1000000000, как обычно, как следствие, вывод вызывается с пустым словарем, в результате ошибка variable not defined. Не совсем понимаю, в правильные ли места в коде я запихал все эти сохранения и операции со строками.
Помогите, пожалуйста.

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
Option Explicit
 
Sub tt()
    Dim sh As Object, SelectedItem
    Dim a(), el
    Dim mi As Long, ma As Long
 
    'для считывания даты, и копирования в имя файла
    Dim day As String, d As String
    'кто текущий кассир; касса - истина; сергей - ложь
    Dim k As Boolean
        
    Dim dic As Object, wb As Object
 
    'вызываем диалог выбора файлов
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Выберите файлы отчетов"    'надпись в окне диалога
        'путь по умолчанию к папке где расположен исходный файл, можно изменить
        .InitialFileName = ThisWorkbook.Path & Application.PathSeparator & "*.xls"
        .AllowMultiSelect = True    'выбор нескольких файлов разрешён
        If .Show = False Then Exit Sub
 
        Application.ScreenUpdating = False
        For Each SelectedItem In .SelectedItems    'перебор файлов в папке
            mi = 1000000000#: ma = 0
            Set dic = CreateObject("scripting.dictionary")
            Set wb = Workbooks.Open(SelectedItem)            'открываем книгу
            'операции с открытой книгой
            d = Mid(Cells(7, 2), 1, 10)
            k = True
            For Each sh In wb.Worksheets
                If sh.UsedRange.Columns.Count > 3 Then
                    a = sh.UsedRange.Columns(4).Value
                    For Each el In a
                        If Len(el) Then
                            If el = "Номер" Then
                                If mi <> 1000000000# Then
                                    day = Mid(d, 1, 2) + Mid(d, 4, 2) + Mid(d, 9, 2)
                                                                        
                                    If k = True Then
                                    day = day & "k"
                                    Else: day = day & "s"
                                    End If
                                    
                                    k = Not k
                                    
                                    vivod dic, mi, ma, day
                                    mi = 1000000000#: ma = 0
                                    Set dic = CreateObject("scripting.dictionary")
                                End If
                            End If
                            If IsNumeric(el) Then
                                dic.Item(Val(el)) = 0&
                                If mi > el Then mi = el
                                If ma < el Then ma = el
                            End If
                        End If
                    Next
                End If
            Next
            wb.Close 0
                        
            day = Mid(d, 1, 2) + Mid(d, 4, 2) + Mid(d, 9, 2)
            
            If k = True Then
            day = day & "k"
            Else: day = day & "s"
            End If
 
            vivod dic, mi, ma, day
            
        Next SelectedItem
    End With
    
        Application.ScreenUpdating = True
 
    Exit Sub
        Application.Quit
End Sub
 
 
Private Sub vivod(sl, mi, ma, day)
    Dim outsh As Object
 
    outsh = Workbooks.Add(1).Sheets(1)
    
    Dim i&, ii&, flagS As Boolean, flagF As Boolean
 
    ReDim a(1 To (ma - mi + 3) / 2 + 1, 1 To 3)
    ii = 1: flagS = True: flagF = True
 
    For i = mi To ma + 1
        If sl.exists(i) Then
            If flagS Then
                a(ii, 1) = i: flagS = False: flagF = True
            End If
        Else
            If flagF Then
                a(ii, 2) = i - 1: a(ii, 3) = a(ii, 2) - a(ii, 1) + 1
                flagS = True: flagF = False: ii = ii + 1
            End If
        End If
    Next
 
    sh.Cells(2, 1).Resize(ii - 1) = "Билет театральный рулонный (1 бил.=1 руб.)"
    sh.Cells(2, 2).Resize(ii - 1) = "ТЕ"
    sh.Cells(2, 3).Resize(ii - 1, 3) = a
    sh.Cells(1, 1).Resize(1, 5) = Array("БСО", "Серия БСО", "Начальный номер", "Конечный номер", "Количество")
 
    outsh.parent.Saved = True 'нужно ли? или при "сохранении как..." Saved автоматически менятеся на true?
 
    outsh.parent.SaveAs Filename:=outsh.parent.Path & "\import\" & day & ".xls", FileFormat:= _
    xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
    , CreateBackup:=False
        
 
End Sub

Новые блоги и статьи Все статьи Все блоги /
Копировать Windows на новый диск на UEFI damix 17.10.2026 https:/ / uriesk. wordpress. com/ 2016/ 11/ 01/ move-window-10-to-ssd-on-a-uefi-dualboot-system-with-basic-linux-tools/ TL DR Вставляем диск, а старый подключаем через переходник, грузимся с лайва. . .	ИИ не может найти нужный язык в списке Supersumestria 05.10.2026 Я ему даю вот такое изображение и прошу найти и подчеркнуть немецкий язык. Возвращает он вот это: https:/ / i. **********/ vqBWLe2. png Нужную строчку в 3й колонке просто выдумал. . Это. . .	Новая последняя моя музыка в SUNO zorxor 05.10.2026 Здравствуйте, дорогие мои друзья! С большой радостью я хотел бы представить вам свою новую последнею музыку, которую сгенерировала мне по моей просьбе нейросеть SUNO. С уважением, zorxor. Это. . .	Программный домашний кинотеатр russiannick 27.09.2026 Сподобился на программный домашний кинотеатр. В качестве ЯВУ по традиции выбрал js. В помощники взял Яндекс-Алису. Было создано три зала на разные интересы. исторические и ретро сериал Хичкок. . .
Беседа с ИИ о программистах, недопускающих к созданию и правке кода генеративные ИИ и причины этого zorxor 21.09.2026 Раньше я радовался или получал некоторые эмоции, пусть небольшие, но всё же, от самого процесса написания кода, рекомпиляции и запуска, видя постепенное развитие программы и прочее. А теперь лень. . .	Мобильное приложение ColorStep pavlinmavlin 17.09.2026 Реализовал приложение Красный, Зеленый, Синий в Unity3d + c#. Название изменил на ColorStep. Приложение прошло модерацию и теперь доступно для скачивания. Делал его сам, шаг за шагом — и вот,. . .	Запрет дублирования строк в табличной части Maks 13.09.2026 Реализация из решения ниже выполнена на нетиповом справочнике "Нормы ТО" с табличной часть "Виды ТО", разработанного в КА2, со следующими реквизитами: - ВидТО (СправочникСсылка. ВидыТО); - ВидГСМ. . .	Скрипты Tampermonkey для CyberForum, ChatGPT, Claude и пр. Jin X 06.09.2026 Скрипты Tampermonkey для CyberForum, ChatGPT, Claude и пр. Работая с форумом и нейросетями в браузере часто хочется что-то подкорректировать или добавить какого-то функционала. Ниже прикреплён. . .

@Alex77755 11525 / 3812 / 683 Регистрация: 13.02.2009 Сообщений: 11,229
	02.02.2014, 08:42
	.exists самая главная фишка словаря! позволяет сразу определиь наличие ключа в словаре. Без перебора всех элементоов 0

@mr sinister 1 / 1 / 0 Регистрация: 28.01.2014 Сообщений: 49
	05.02.2014, 17:11 [ТС]
	1. Перейти не получится. А нельзя ли как то хранить предыдущий элемент для его обработки в следующей итерации? Я над этим корчился-тужился, но так и не осилил. 2. Если использовать не For Each, а другие типы циклов, чтобы обращаться к любым элементам, то нужен собственно массив состоящий из всего 4 столбца РАБОЧЕЙ КНИГИ. Количество всех строк уже есть, осталось получить такой массив. Как? 0

@mr sinister 1 / 1 / 0 Регистрация: 28.01.2014 Сообщений: 49
	07.02.2014, 03:28 [ТС]
	Hugo121, во-первых спасибо за доработанную версию. Во-вторых нет, кассиров стабильно двое. В-третьих, насчет файлов, это оно? Или можно проще, без центрального файла? 0

@Hugo121 6998 / 2896 / 555 Регистрация: 19.10.2012 Сообщений: 8,804
	07.02.2014, 10:52
	Нет. Т.к. у Вас там много таких файлов с билетами, а этот код обрабатывает только один активный файл (у меня код расположен в другом файле - это может быть и personal.xls как по ссылке, но у меня просто пустой файл-"инструмент" с этим кодом), то думаю есть смысл добавить в код последовательную обработку нескольких файлов с билетами. Есть варианты: обрабатываем не глядя все файлы определённой папки обрабатываем не глядя все файлы выбранной в диалоге папки обрабатываем все выбранные пользователем в диалоге файлы Если файлов будет много - то думаю нужно доработать вывод собранного. Например вот получите Вы 40 таких парных столбцов, без привязки к файлам - их ведь дальше опять нужно вручную как-то обрабатывать... 0

@mr sinister 1 / 1 / 0 Регистрация: 28.01.2014 Сообщений: 49
	11.02.2014, 06:47 [ТС]
	Hugo121, конечно, обрабатываем все выбранные пользователем в диалоге файлы 0

@mr sinister 1 / 1 / 0 Регистрация: 28.01.2014 Сообщений: 49
	14.02.2014, 22:49 [ТС]
	Hugo121, проясню - протестив на деле процесс импорта, я сделал вывод, что удобнее не разделять кассиров в одном отчете отступом на листе, а помещать их в разные рабочие книги, и, соответственно, сохранять эти две разных рабочих книги соответственно с постфиксами "k" и "s". 0

@Hugo121 6998 / 2896 / 555 Регистрация: 19.10.2012 Сообщений: 8,804
	14.02.2014, 23:19
	Ну тогда можно брать сразу все файлы, новую книгу генерить в начале Sub vivod(), сохранять-закрывать её в конце Sub vivod() 0

@mr sinister 1 / 1 / 0 Регистрация: 28.01.2014 Сообщений: 49
	14.02.2014, 23:27 [ТС]
	Hugo121, проясните, пожалуйста: 1. Обращаться для сохранения к wb или к SelectedItem? 2. Какие собственно команды использовать, чтобы спуститься на уровень ниже в заданную папку (можно без On Error, папка 100% там будет) и сохранить текущую книгу с заданным именем? 0

@Hugo121 6998 / 2896 / 555 Регистрация: 19.10.2012 Сообщений: 8,804
	14.02.2014, 23:31
	1. Ни так ни эдак - создайте Set outsh = Workbooks.Add(1).Sheets(1) внутри этого макроса, и там же сохраняйте-закрывайте. 2. Зачем на уровень ниже? Просто сохраняйте файл по полному пути - имя папки интегрируйте в путь. Вопрос где брать имя кассира - в моём коде для этого нужно ещё один массив перебирать.... 0

@mr sinister 1 / 1 / 0 Регистрация: 28.01.2014 Сообщений: 49
	14.02.2014, 23:40 [ТС]
	Hugo121, 1. Ясно-понятно. 2. Все отсортировано по месяцам, так что полный путь будет раз в месяц разный. Имя кассира знать не нужно и брать соответственно тоже. Просто в начале обработки файла к равно истине - первый кассир - касса. При следующем обнаружении слова "номер" к становится ложью, значит, кассир - сергей. С каждым новым фацлом сбрасывается. И да. Как собственно сохранять то этот outsh? Всмысле какой командой имя файла, путь задавать и прочее? 0

@Hugo121 6998 / 2896 / 555 Регистрация: 19.10.2012 Сообщений: 8,804
	14.02.2014, 23:51
	Как сохранять - запишите нужный процесс рекордером, возьмите код. Как вставить путь - разберётесь. Ну а сам файл будет outsh.parent 1

Преобразование типов для копирования определенных ячеек из одного столбца в массив

Решение