Вывод данных из listbox

[СтаниславАВ]

Проблемы с макросом DimFirm:

'Список фирм из базы (составляем и сортируем)
Public DimFirm() As String 'массив с названиями фирм
Option Explicit
'компонуем таблицу из базы данных адресов
Public Sub CreateDim()
Call FillDim 'заполнение таблицы фирмами из базы
Call SortDim 'сортируем таблицу
End Sub
'заполнение таблицы фирмами из базы
Private Sub FillDim()
Dim i As Integer 'строка очередной фирмы
Dim j As Byte 'столбец очередной фирмы
Dim kol As Integer 'количество адресов
With shHome
For i = 1 To rowH 'просматриваем все используемые ячейки
For j = 1 To colH
If Not IsEmpty(.Cells(i, 3)) Then 'если ячейка не пустая - заносим в таблицу
kol = kol + 1 'количество найденных фирм увеличиваем на 1
ReDim Preserve DimFirm(1 To kol) 'добавляем ячейку
On Error Resume Next
DimFirm(kol) = shHome.Cells(i, 3).Comment.Text 'переносим название фирмы из комментария в таблицу
End If
Next
Next
End With
End Sub
'сортируем таблицу (пузырьковый метод)
Private Sub SortDim()
Dim kol As Byte: kol = UBound(DimFirm) 'размерность массива
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim min As String
Dim buf As String
If kol >= 1 Then 'а вдруг массив только из 1-й ячейки!?
For i = 1 To kol - 1 'от 1-го до предпоследнего
min = DimFirm(i + 1): k = i + 1
For j = i + 1 To kol 'от i-го до последнего
If DimFirm(j) < min Then 'если нашли меньше
min = DimFirm(j) 'запоминаем значение
k = j 'запоминаем позицию
End If
Next
If min < DimFirm(i) Then 'если нашли меньше - меняем местами
buf = DimFirm(i): DimFirm(i) = min: DimFirm(k) = buf
End If
Next
End If
End Sub

[СтаниславАВ]

'Список фирм из базы (составляем и сортируем)
Public DimFirm() As String 'массив с названиями фирм
Option Explicit
'компонуем таблицу из базы данных адресов
Public Sub CreateDim()
   Call FillDim 'заполнение таблицы фирмами из базы
   Call SortDim 'сортируем таблицу
End Sub
'заполнение таблицы фирмами из базы
Private Sub FillDim()
   Dim i As Integer 'строка очередной фирмы
   Dim j As Byte 'столбец очередной фирмы
   Dim kol As Integer 'количество адресов
   With shHome
      For i = 1 To rowH 'просматриваем все используемые ячейки
         For j = 1 To colH
            If Not IsEmpty(.Cells(i, 3)) Then 'если ячейка не пустая - заносим в таблицу
                kol = kol + 1 'количество найденных фирм увеличиваем на 1
                ReDim Preserve DimFirm(1 To kol) 'добавляем ячейку
                On Error Resume Next
                DimFirm(kol) = shHome.Cells(i, 3).Comment.Text 'переносим название фирмы из комментария в таблицу
            End If
         Next
      Next
   End With
End Sub
'сортируем таблицу (пузырьковый метод)
Private Sub SortDim()
   Dim kol As Byte: kol = UBound(DimFirm) 'размерность массива
   Dim i As Integer
   Dim j As Integer
   Dim k As Integer
   Dim min As String
   Dim buf As String
   If kol >= 1 Then 'а вдруг массив только из 1-й ячейки!?
      For i = 1 To kol - 1 'от 1-го до предпоследнего
         min = DimFirm(i + 1): k = i + 1
         For j = i + 1 To kol 'от i-го до последнего
            If DimFirm(j) < min Then 'если нашли меньше
               min = DimFirm(j) 'запоминаем значение
               k = j 'запоминаем позицию
            End If
         Next
         If min < DimFirm(i) Then 'если нашли меньше - меняем местами
            buf = DimFirm(i): DimFirm(i) = min: DimFirm(k) = buf
         End If
      Next
   End If
End Sub

Так лучше будет

[kuklp]

Сергей писал:
"1 DimFirm имя модуля и одновременно имя переменной-красная карточка."
Переименуйте либо одно - либо другое.

[СтаниславАВ]

А вот форма вывода:

'окно для вставки ЖКУ
Option Explicit
'"Стереть всё" - очищаем новый список
Private Sub AllLeft_Click()
   ListBox2.Clear 'очищаем список с выбранными фирмами
   Вставка_ЖКУ.Caption = ListBox2.ListCount 'в заголовке диалога количество выбранных фирм - 0!
End Sub
'"Добавить всё" - перенести все фирмы в новый список
Private Sub AllRight_Click()
   If Not IsEmpty(shHome) Then
      If Not Dublicate Then ListBox2.Clear 'очищаем список выбранных фирм если запрещено дублирование адресов
      Dim i As Byte 'порядковый номер фирмы из основного списка
      For i = 0 To ListBox1.ListCount - 1 'от первой и до последней фирмы в основном списке
         ListBox2.AddItem ListBox1.List(i) 'добавляем её в список выбранных фирм
      Next
      Вставка_ЖКУ.Caption = ListBox2.ListCount 'в заголовке диалога количество выбранных фирм
   End If
End Sub
'"Отмена" - ничего не делаем, выгружаем форму
Private Sub Cancel_Click()
   Unload Me 'выгружаем диалог
   Call DeletePublicVars 'уничтожаем переменные уровня проекта
End Sub

Private Sub Label1_Click()

End Sub

'"Светим" адрес выбранной фирмы (среди выбранных адресов)
Private Sub ListBox1_Click()
   Call SvetimAdres(ListBox1.Value)
End Sub
'щелчок на основном (левом) списке - перенос выбранной фирмы в новый (правый) список
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
   Call ToRight_Click 'добавляем выбранную фирму в новый список
End Sub
'"Светим" адрес выбранной фирмы (среди имеющихся алресов)
Private Sub ListBox2_Click()
      Call SvetimAdres(ListBox2.Value)
End Sub
'щелчок на новом (левом) списке - удаление из него выбранной фирмы
Private Sub ListBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
   Call ToLeft_Click 'удаляем из нового списка выделенную фирму
End Sub
'"ОК" - готовим к печати выбранные адреса
Private Sub OK_Click()
   If ListBox2.ListCount <> 0 Then
      Call CreateStick 'если что-то выбрали - переносим адреса
   Else: Exit Sub 'если ничего не выбрали - выход из процедуры
   End If
   Unload Me 'выгружаю диалог
   'и выделяем последнюю непустую ячейку
   Dim RC As Integer 'строка последней заполненной ячейки
   RC = ListBox2.ListCount \ 3
   If ListBox2.ListCount Mod 3 > 0 Then RC = RC + 1
   
    If Intersect(ActiveCell, Range("Расходы[Код]")) Is Nothing Then
    MsgBox "Выделите ячейку в столбце Код", 64: Exit Sub
   
   Dim cc As Byte 'столбец последней заполненной ячейки
   With shNew
      For cc = 1 To 3
         If IsEmpty(.Cells(RC, cc + 1)) Then
            .Cells(RC, cc).Select
            Exit For
         End If
      Next
   End With
End Sub

Private Sub SpinButton1_Change()
Label4.Caption = Date + SpinButton1.Value
End Sub

Private Sub SpinButton2_Change()
Label5.Caption = Date + SpinButton2.Value
End Sub

'"Добавить" - добавляем выбранную фирму в новый список
Private Sub ToRight_Click()
   If ListBox1.ListIndex = -1 Then Exit Sub 'выход если ни одна фирма не выбрана
   Dim i As Byte 'очередная новая выбранная фирма
   If Not Dublicate Then 'если запрещено дублирование, то надо посмотреть нет ли уже этой фирмы в новом списке
      If ListBox2.ListCount > 0 Then 'если новый список уже не пуст
         For i = 0 To ListBox2.ListCount - 1 'просматриваем его
            If ListBox1.Value = ListBox2.List(i) Then 'если такая фирма уже выбрана
               Exit Sub 'то не добавляем её в новый список
            End If
         Next
      End If
   End If
   ListBox2.AddItem ListBox1.Value 'добавляем выбранную фирму в новый список
   Вставка_ЖКУ.Caption = ListBox2.ListCount 'в заголовке диалога количество выбранных фирм
End Sub
'"Стереть" - удаляем из нового списка выделенную фирму
Private Sub ToLeft_Click()
   If ListBox2.ListIndex = -1 Then Exit Sub 'если ничего не выбрано то выход
   ListBox2.RemoveItem ListBox2.ListIndex 'удаляем выбранную фирму
   Вставка_ЖКУ.Caption = ListBox2.ListCount 'в заголовке диалога количество выбранных фирм
End Sub
'при открытии формы - заполнение левого списка фирмами из базы
'(если в базе хоть что-то есть)
Private Sub UserForm_Activate()
   If Not IsEmpty(shHome) Then Call FillLeft '"заливаем" список фирм
End Sub
'Дублирование разрешено (запрещено)
Private Function Dublicate() As Boolean
   Dublicate = CheckBox1.Value
End Function
'заполнение левого списка фирмами из базы
Private Sub FillLeft()
   Call CreateDim 'составить отсортированный список фирм
   Вставка_ЖКУ.ListBox1.List = DimFirm 'загрузить список в диалог
End Sub

[СтаниславАВ]

Удалил .Comment из макроса DimFirm

[СтаниславАВ]

Попрежнему ошибка в макросе DimFirm

[doober]

Вот как вам помогать,если вы не делаете никаких выводов.Посмотрите,как я переименовал модуль.Причем здесь коменты.
Я бы советовал начать с нуля.Больше смотреть не буду

[СтаниславАВ]

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

Вот как вам помогать,если вы не делаете никаких выводов.Посмотрите,как я переименовал модуль.Причем здесь коменты.
Я бы советовал начать с нуля.Больше смотреть не буду

Прошу прощения за назойливость. Просто за образец брал чужой макрос. И сам в нём разбирался.

[doober]

Посмотрите здесь,возможно и пригодится
Молоток добавляет данные.Надо еще и дату выбрать

[СтаниславАВ]

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

Посмотрите здесь,возможно и пригодится
Молоток добавляет данные.Надо еще и дату выбрать

Спасибо. Попрактикуюсь. А ссылку на макрос Красный_свет или DimFirm указывать?