Страницы: 1
RSS
Информация из комментария ячейки в массив
 

Уважаемые гуру форума, подскажите пожалуйста, есть ли АЛЬТЕРНАТИВНОЕ решение у задачи. Ситуация такая: словарем создается массив данных, который записывается в листбокс:

Код
For i = 1 To UBound(x) 'цикл на формирование списка документов  If Month(x(i, 2)) & Year(x(i, 2)) = Month(Me.Mes.Value & "." & Me.God.Caption) & Me.God.Caption Then 'совпадение по месяцу и году расходного документа    temp = x(i, 1) & "|" & x(i, 2) & "|" & x(i, 3) & "|" & x(i, 4) 'номер док-та|дата док-та|наименование товара д/договора|потребитель    .Item(temp) = .Item(temp) + x(i, 7) * x(i, 8)  End IfNext i                On Error Resume Next                ReDim Arr_data(1 To .Count, 1 To 5)                For Each k In .Keys                    Data = Split(k, "|")                    j = j + 1                    Arr_data(j, 1) = Format(Data(1), "dd.mm.yy") 'дата документа                    Arr_data(j, 2) = CStr(Data(0)) 'номер документа                    Arr_data(j, 3) = Data(3) 'потребитель                    Arr_data(j, 4) = Format(CDbl(Split(.Item(k), "-")(0)), "0.00")                    Arr_data(j, 5) = Data(2) 'наименование товара для договора (столбец нулевой длины)                Next k                    Me.Data.Clear                    Me.Data.List = Arr_data        End With

Все работает правильно. Но возник такой вопрос: информация из столбца D (наименование товара для договора) используется в дальнейшем только для 1 вида документов и родилась такая мысль: убрать этот столбец полностью, а информацию из него поместить в комментарий к ячейке. Поясню, при вводе нового документа расхода я вношу в соответствующую ячейку комментарий (в примере ячейки Е2 и Е5) с обобщенным наименованием товара для договора. Как в дальнейшем мне извлечь эту информацию из комментария и поместить ее в массив Arr_Data? Что-то типа temp = x(i, 1) & "|" & x(i, 2) & "|" информация из комментария & "|" & x(i, 4). Можно ли так сделать? Сейчас все работает, так что если такой вариант невозможен, то ничего страшного. Заранее спасибо всем откликнувшимся.

Изменено: OlegO - 12.03.2018 09:20:04
 
Уважаемые гуру, это вообще возможно? (Я имею ввиду извлечение информации из комментария одной из ячеек массива). Или проще плюнуть на идею сокращения кол-ва столбцов?
 
Цитата
OlegO написал: это вообще возможно?
ВООБЩЕ возможно, но прямым занесением в массив по типу arr = Range("A1:A10").Value не получится. Только перебором ячеек или коллекции примечаний листа
Согласие есть продукт при полном непротивлении сторон
 
Мысль свою о ликвидации колонки выкинуть так и не смог 8-0 , решил пойти таким путем: сначала пройти по ячейкам и выбрать в массив только примечания, далее обработать ячейки с данными ну и далее объединить массивы (по высоте они обязаны быть (если пользователь не накосячит) одинаковы. В итоге получилось следующее:
Код
Private Sub Mes_Change()
    Dim i As Long, j As Long, temp As String, Arr_data(), arr(), x(), Data As Variant, k As Variant
        With CreateObject("Scripting.Dictionary"): .CompareMode = 1 'формирование словаря по данным исходного массива
            x = Sheets("Расход").Range("B2:H" & Sheets("Расход").Cells(Rows.Count, 5).End(xlUp).Row).Value 'данные в массив
            y = Sheets("Расход").Range("A2:C" & Sheets("Расход").Cells(Rows.Count, 6).End(xlUp).Row).Value 'данные в массив
                
                For i = 1 To UBound(y) 'цикл на формирование списка комментариев
                    If y(i, 1) = "Н" Then
                        If Month(y(i, 3)) & Year(y(i, 3)) = Month(Me.Mes.Value & "." & Me.God.Caption) & Me.God.Caption Then 'совпадение по месяцу и году расходного документа
                            .Add Cells(i + 1, 4).Comment.Text, 1
                        End If
                    End If
                Next i
                
                On Error Resume Next

                ReDim Arr_t(1 To .Count, 1 To 1)
                For Each k In .Keys
                    j = j + 1
                    Arr_t(j, 1) = k 'комментарии
                Next k
                
                .RemoveAll

                For i = 1 To UBound(x) 'цикл на формирование списка документов
                        If Month(x(i, 2)) & Year(x(i, 2)) = Month(Me.Mes.Value & "." & Me.God.Caption) & Me.God.Caption Then 'совпадение по месяцу и году расходного документа
                            temp = x(i, 1) & "|" & x(i, 2) & "|" & x(i, 3) 'номер док-та|дата док-та|наименование товара д/договора|потребитель
                            .Item(temp) = .Item(temp) + x(i, 6) * x(i, 7)
                        End If
                Next i
                        
                j = 0
                ReDim Arr_data(1 To .Count, 1 To 4)
                For Each k In .Keys
                    Data = Split(k, "|")
                    j = j + 1
                    Arr_data(j, 1) = Format(Data(1), "dd.mm.yy") 'дата документа
                    Arr_data(j, 2) = CStr(Data(0)) 'номер документа
                    Arr_data(j, 3) = Data(2) 'потребитель
                    Arr_data(j, 4) = Format(CDbl(Split(.Item(k), "-")(0)), "0.00")
                Next k
                
                j = 0
                ReDim Arr_dataP(1 To .Count, 1 To 5)
                For Each k In .Keys
                    Data = Split(k, "|")
                    j = j + 1
                    Arr_dataP(j, 1) = Arr_data(j, 1) 'дата документа
                    Arr_dataP(j, 2) = Arr_data(j, 2) 'номер документа
                    Arr_dataP(j, 3) = Arr_data(j, 3) 'потребитель
                    Arr_dataP(j, 4) = Arr_data(j, 4)
                    Arr_dataP(j, 5) = Arr_t(j, 1)
                Next k
                    Me.Data.Clear
                    Me.Data.List = Arr_dataP
        End With
End Sub
проверил, вроде бы все работает. Прошу указать на недостатки в коде, если кто увидит. (например мне самому кажется лишним использование словаря  .Add Cells(i + 1, 4).Comment.Text, 1) для отбора примечаний, тут ведь наверное и сразу массив можно было заполнить, но вот как пока не знаю). Одним словом прошу взглянуть на код  и указать на ошибки и недоработки, если они есть.
Страницы: 1
Наверх