» Excel VBA

aks_sv
Если бы ты сделал, как я сказал, выгружались бы все данные целиком (я проверял )
Тут несколько вариантов - либо у тебя в ListBox столбец только один, либо ты задал диапазон из одного столбца (первый_столбец = последний_столбец).
Выложи свой файл - тогда смогу сказать точно.

The okk
[q][/q]
Private Sub UserForm_Initialize()
Application.ScreenUpdating = False
ListBox1.ColumnCount = 9
ListBox1.ColumnWidths = "30;0;0;0;0;0;0;0;0"
Dim myArray As Variant
myArray = Worksheets("Данные").Range("A2:I400")
ListBox1.List = myArray
End Sub

Действительно, у меня загружается один стобец, почему?


Добавлено:
The okk
Private Sub cb_EmpExit_Click()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Range("A65536").End(xlUp).Row
With Worksheets("Список")
.Range(.Cells(2, 1), _
.Cells(LastRow, 9)) = _
Me.ListBox1.List
End With
Unload Me
Worksheets("Табель").Activate
End Sub

А как вы пишите мелким шрифтом на белом фоне в форуме?

Добавлено:
The okk
Получается, что все ж загружаютя, потому, что еслизаписать:
ListBox1.ColumnWidths = "30;30;0;0;0;0;0;0;0"
то все ОК, только в окне два столбца, а мне не надо

Добавлено:

Нет все нормально, только когда я начинаю значения в Listbox перемещать вверх-вниз, тогда не получается

Private Sub Up_Button_Click()
If ListBox1.ListIndex <= 1 Then Exit Sub
NumItems = ListBox1.ListCount
Dim TempList()
ReDim TempList(0 To NumItems - 1)
' Заполнить массив опциями списка
For i = 0 To NumItems - 1
TempList(i) = ListBox1.List(i)
Next i
' Выделенные пункты
ItemNum = ListBox1.ListIndex
' Обменять элементы
TempItem = TempList(ItemNum)
TempList(ItemNum) = TempList(ItemNum - 1)
TempList(ItemNum - 1) = TempItem
ListBox1.List = TempList
' Изменить индекс списка
ListBox1.ListIndex = ItemNum - 1
End Sub
Private Sub Down_Button_Click()
If ListBox1.ListIndex = ListBox1.ListCount - 1 Then Exit Sub
NumItems = ListBox1.ListCount
Dim TempList()
ReDim TempList(0 To NumItems - 1)
' Заполнить массив опциями списка
For i = 0 To NumItems - 1
TempList(i) = ListBox1.List(i)
Next i
' Выделенные пункты
ItemNum = ListBox1.ListIndex
' Обменять элементы
TempItem = TempList(ItemNum)
TempList(ItemNum) = TempList(ItemNum + 1)
TempList(ItemNum + 1) = TempItem
ListBox1.List = TempList
' Изменить индекс списка
ListBox1.ListIndex = ItemNum + 1

End Sub

Цитата:

А как вы пишите мелким шрифтом на белом фоне в форуме?

Используй форумные теги в сообщениях.

Можешь сам посмотреть, что твой код делает - добавь в код точки останова (F9) и запусти. А в ходе выполнения кода открой окно Watches и перетащи туда Me.ListBox1.List и увидишь со всеми подробностями, что происходит с элементами. - В будущем тебе еще не раз пригодится это окошко.
P.S.:Не люблю я Debug.print - жутко неудобно.


Цитата:

Private Sub Up_Button_Click()
If ListBox1.ListIndex <= 1 Then Exit Sub
NumItems = ListBox1.ListCount
Dim TempList()
ReDim TempList(0 To NumItems - 1)
' Заполнить массив опциями списка
For i = 0 To NumItems - 1
TempList(i) = ListBox1.List(i)
Next i
' Выделенные пункты
ItemNum = ListBox1.ListIndex
' Обменять элементы
TempItem = TempList(ItemNum)
TempList(ItemNum) = TempList(ItemNum - 1)
TempList(ItemNum - 1) = TempItem
ListBox1.List = TempList
' Изменить индекс списка
ListBox1.ListIndex = ItemNum - 1
End Sub

"меня терзают смутные сомненья..." ©
А работает ли вообще этот код? Где Else, End If? Да и переменные NumItems и ItemNum хорошо бы объявить - это не так критично, как отсутствие End If, но все же между Variant и Long разница есть.
Насколько я понял, одна кнопка должна перемещать выделенный элемент вверх, а другая - вниз. А вот алгоритм перемещения не могу разобрать. как это должно работать?

The okk

Цитата:

Спасибо за теги и про отладку

А насчет работы кода не сомневайся, работает прекрасно я в какой-то книжке вычитал давно

aks_sv
честно говоря, сомневаюсь, что в этой книжке был код для твоего случая. Поскольку предназначен этот код для случая ListBox с одним столбцом.

Ты в алгоритме разберись:

ЕСЛИ выделен не первый и не второй элемент, ТО
1. Скопировать весь первый столбец во временный массив (TempList). В результате имеем одномерный массив.
2. Переставить в этом массиве элементы через буфер
3. Загрузить этот ОДНОМЕРНЫЙ массив в ListBox.

Вот так при нажатии кнопки у тебя остается только первый столбец.

Если уж все копировать в массив, то копировать целиком в двойном цикле - вместо List(i) - List(i,j), где j меняется от 0 до 8 (поскольку столбцов 9).
И менять местами тоже все эти подэлементы. [more=Вот так выглядит исправленный код]
Код: Private Sub Up_Button_Click()
If ListBox1.ListIndex <= 1 Then Exit Sub
NumItems = ListBox1.ListCount
Dim TempList()
Dim TempItem(0 To 8)
ReDim TempList(0 To NumItems - 1, 0 To 8)
For i = 0 To NumItems - 1
For j = 0 To 8
TempList(i, j) = ListBox1.List(i, j)
Next j
Next i
ItemNum = ListBox1.ListIndex
For j = 0 To 8
TempItem(j) = TempList(ItemNum, j)
TempList(ItemNum, j) = TempList(ItemNum - 1, j)
TempList(ItemNum - 1, j) = TempItem(j)
Next j

ListBox1.List = TempList

ListBox1.ListIndex = ItemNum - 1
End Sub

Кому-то надо группировки одинаковых имен и т.д.?
Вставь новая форма, добавь элемент поля со списком и вставить туда коды:

Код: Function ГруппаТекст(ByVal ARange As Range) As String()
Dim Cnt As Long, i As Long, TArr(), TArrItm, TempArr() As String
Dim tArea As Range
ReDim TempArr(0)
For Each tArea In ARange.Areas
TArr = tArea.Value
For Each TArrItm In TArr
If Len(TArrItm) > 0 Then
For i = 0 To Cnt - 1
If TempArr(i) = TArrItm Then Exit For
Next
If i = Cnt Then
ReDim Preserve TempArr(Cnt)
TempArr(Cnt) = TArrItm
Cnt = Cnt + 1
End If
End If
Next
Next
ГруппаТекст = TempArr
End Function

Private Sub UserForm_Initialize()
ComboBox1.List = ГруппаТекст(Range("a1:a10"))
End Sub

Anton T
Лучше все же писать комментарии к коду или алгоритм
Кстати, столбец с уникальными значениями делается формулой .

The okk
Спасибо все отлично работает
Цитата:

Если уж все копировать в массив, то копировать целиком в двойном цикле - вместо List(i) - List(i,j), где j меняется от 0 до 8 (поскольку столбцов 9).
И менять местами тоже все эти подэлементы. Вот так выглядит исправленный код
Вставь вместо своего и исправь код второй кнопки по этому образцу.

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

ZORRO2005
В код листа:
Код: Private Sub Worksheet_Change(ByVal Target As Range)
Dim frm As String
frm = ""
If Target.Address = "$A$2" Then
For Each c In Range(Range("F1"), Range("F1").End(xlDown)).Cells
If c.Value = Target.Value Then
frm = frm & "," & c.Offset(0, 1).Text
End If
Next
With Range("B2").Validation
.Delete
.Add Type:=xlValidateList, Formula1:=frm
.IgnoreBlank = True
.InCellDropdown = True
.ShowInput = True
.ShowError = False
End With
End If
End Sub

Yuk

Цитата:

Сортировать не обязательно.

Я просто хотел ускорить процесс - на собственном опыте убедился, что поиск в массиве на листе с использованием цикла - это "от лукавого" ибо при большом количестве записей вызывает тормоза. Поэтому больше такой поиск не использую, а если что-то надо искать, ищу через Worksheetfunction.Match и Index (и им подобные) - на порядок быстрее.
А сортировка нужна затем, что при сортированном массиве отпадает необходимость проходить по всему массиву. Достаточно с помощью Worksheetfunction найти первое совпадение и от него идти вниз, пока содержимое ячейки в столбце А совпадает с содержимым ячейки в столбце F. Получается, что пройти надо будет не весь массив, а лишь его небольшую часть. Про сортировку спросил только из-за этого.
Кроме того, удаление элемента также вызывает это событие, поэтому надо еще и проверять, что там вообще за Target. Если Empty, то вместо добавления Validation в столбец В, его надо удалить и вообще зачистить ячейку, чтобы на пустом месте не оставалось никаких непонятно к чему относящихся цифр.
А что вот это даст:
Цитата:

Target.Address = "$A$2"

- это же только для первой ячейки, а, насколько я понял, нужно для всего столбца. Или я что-то не так понял?
Я просто недавно похожий скрипт писал.

С прошедшими тебя праздниками и наступающим СНГ!

Yuk
Спасибо большое.
Но это только для ячейки A2
1. А как сделать так чтобы в ячеках A3,A4,A5...также получалось.
Ну максимум до A25
2. Если я меняю значение в столбце G то можно сделать обновляющийся
выпадающий список в столбце B?
Сейчас обновляется только после того как я поменяю значения в столбце A.

Уважаемый ZORRO2005, и многоуважаемые The okk и Yuk.
Вчера написал пост - но то ли я сбойнул, то ли винда... короче, я его не вижу... ;-((
и развитие событий с разработкой скрипта позволяет мне повторить свою мысль:
я понимаю, что Excel бесконечно сильная штука и позволяет вытворять чудеса, заменяющие SQL, даже с нескольким взаимосвязанными таблицами (реляционная СУБД, блин ;-))) Но стоит ли овчинка выделки? задача ZORRO2005 просто просится быть запрограммированой в ЛЮБОЙ СУБД (хоть в том же Access'е)!! Просто куча геморроя уходит (я имею в виду, что 1500 строк в столбце F и 1000 уникальных значений для них в G будут вызывать серьёзные проблемы со скоростью обработки, ИМХО...) Плюс хлопоты, связанные с поддержанием целостности в столбце B при изменении, переименовании, удалении и добавлении данных в столбце F ... ) как я вижу, задача решается, и даже достаточно эффективно, но, повторю - ИМХО, ZORRO2005, вам стоит задуматься о программе с СУБД...

Yuk, А за красивый скрипт - Большое спасибо, он в моей копилке займёт достойное место!! ;-))

Добавлено:
Yuk мне кажется будет более эффективным сделать следующее:
1) в Worksheet_Change проверять изменение в заполненном диапазоне FG
формировать новый столбец B и в скрытом столбце (ну скажем E) хранить строчку валидации (то, что накапливается в frm)

2) при изменениях в столбце A по таргету брать сохранённую строку из скрытого столбца (E) и устанавливать её для валидации с нужной строчке для столбца B

3) The okk прав - и столбец FG лучше сделать ОТСОРТИРОВАННЫМ...

ZORRO2005
The okk прав, могут быть тормоза при таком раскладе.
Какого размера ожидается массив в столбцах F и G? Сколько максимально может быть величин на месяц?
1. 1-е условие меняется на If Target.Column = 1 Then
Надо подумать, как сделать это эффективнее. Возможно через динамический массив.

Добавлено:

Цитата:

в скрытом столбце (ну скажем E) хранить строчку валидации (то, что накапливается в frm)

Вот это неплохая мысль!

SERGE_BLIZNUK


Цитата:

задуматься о программе с СУБД...

а я не очень разбираюсь в ACCESS,1С.... а EXCEL очень люблю,
а платить за СУБД для каждой такой похожей задачи мне накладно.
Кстати эту задачу попросил решить человек,который все время работает в 1С.
Огромное спасибо Yuk,который не первый раз мне помогает, а также
многим другим,кто поддерживает этот форум.

Добавлено:
The okk

Цитата:

это же только для первой ячейки, а, насколько я понял, нужно для всего столбца. Или я что-то не так понял?

да, правильно

Добавлено:
Yuk

Цитата:

1-е условие меняется на If Target.Column = 1 Then

Что-то не получается


Добавлено:

Цитата:

Какого размера ожидается массив в столбцах F и G? Сколько максимально может быть величин на месяц?

в столбце F около 1000 в столбце F около 3000
макс.на месяц 10

ZORRO2005

Цитата:

я не очень разбираюсь в ACCESS,1С.... а EXCEL очень люблю,
а платить за СУБД для каждой такой похожей задачи мне накладно

А кто говорит - "платить" ?? Я почему и вспомнил Access (не к ночи он будь помянут ;-))
что он ориентирован на конечного пользователя (поэтому и входит в MS Office) - научиться им пользоваться (именно пользоваться) - не намного сложнее, чем программировать на VBA!
Конечно, то, что Вы на нём сделаете будет мягко говоря не очень быстро работать и не выдержит никакой критики со стороны нормальной СУБД (кстати, cейчас и MS SQL и Oracle базу данных до 4 Гиг держат БЕСПЛАТНО) - но это уже совсем другая песня...
впрочем, Вам (или Вашему товарищу) решать - чем пользоваться и чем при этом жертвовать... ;-) - "каждый выбирает по себе..."

Yuk
Цитата:

Вот это неплохая мысль

так, совместными усилиями и добьём... ;-))

ZORRO2005
Цитата:

Цитата: 1-е условие меняется на If Target.Column = 1 Then

Что-то не получается

Yuk

Цитата:

If Target.Column = 1

А что будет в свойстве .Column, если Target Is Empty?

P.S.: Обычно
Код: If Not Target Intersect Range("A:A") is Empty

К вопросу выборки уникальных значений - проще и быстрее всего завести Collection и добавлять элементы по ключу, а потом читать всё подряд

Dim UnqArray As New Collection, rng, val
LastRow = Sheets("Sheet1").Range("A65536").End(xlUp).Row
On Error Resume Next ' позаботимся о dup keys
For Each rng In Sheets("Sheet1").Range("A1:A" & LastRow)
val=rng.value
UnqArray.Add Item:=val, key:=CStr(val) ' dup keys не добавятся
Next rng

For Each val in UnqArray.Item
.....
Next val



Добавлено:
Надеюсь всё же получить когда-нить ответ на свой вопрос

Цитата:

Требуется сохранить worksheet с русским текстом в файл, чтобы в файле получился оттабулированный текст, т.е. чтоб все строчки в колонках чётко начинались в одних и тех же позициях. Не нашёл, как такое сделать, поэтому сначала сцепил все колонки построчно в одну выравнивая текст дополнительными пробелами и эту одну широченную колонку пытаюсь сохранить в файл. Делаю следующие манипуляции
ActiveWorkbook.SaveAs FileName:="MyFile.txt", FileFormat:=xlUnicodeText, CreateBackup:=False
В результате в файле имеем красиво оттабулированный текст, только .... он в двойных кавычках... Такое вот безобразие.. Приходится потом файл вручную редактировать и удалять кавычки.
Как упростить процедуру, или, если такое низзя, то как сохранить в файл, чтоб было без кавычек?

vzbzdnov

Цитата:

worksheet с русским текстом в файл, чтобы в файле получился оттабулированный текст

FileFormat := xlTextWindows (Текстовые файлы с разделителями табуляции)

SERGE_BLIZNUK

Цитата:

в скрытом столбце (ну скажем E) хранить строчку валидации (то, что накапливается в frm)

Да, мысль верная. Только вот формировать строку (String) - идея не самая лучшая, поскольку во-первых, тип String ограничен количеством символов (много чисел в 255 символов не уместишь), а во-вторых, до 10 конкатенаций на создание каждой строчки валидации (быстродействие не на высоте).
Думаю, где-то нужно иметь диапазон со списком валидации. А в валидацию прописывать только имя этого диапазона. Формироваться эти диапазоны будут формулами. При таком подходе будем иметь:
1. Уход от использования множественных конкатенаций.
2. Максимально быстрое изменение существующих валидаций при изменении в FG. (поскольку диапазон для валидации будет формироваться формулами, а не VBA-скриптом).
3. Уход от сортировок.
Только надо решить частные вопросы: конкретный вид формулы для имени диапазона, формула формирования диапазонов на основе FG, где будут храниться эти диапазоны.

The okk
Цитата:

Что-то мне тут не нравится. Попробуй выделить в первом столбце несколько заполненных клеток и удали в них значения (Del)...

тут и говорить не о чем... это БЕССПОРНО!!! Это очень черновой вариант, просто, чтобы показать ZORRO2005 как это будет выглядеть... ;-))


Цитата:

Думаю, где-то нужно иметь диапазон со списком валидации. А в валидацию прописывать только имя этого диапазона.

в том посте, который потерялся (очень жаль..;((() - я как раз и шёл в этом направлении. Т.е., пока я не увидел решение Yuk, и мне нужно было бы решить такую задачу, я бы одназначно шел в сторону создания заполненого списка (в скрытой области или листе) и подсовывания его в область B для валидации. Только я не представлял (и не представляю пока) как это можно получить без VBA - только с помощью формул...

и ещё раз повторю - задача просто "просится" быть запрограммированной с помощью СУБД ;-))

vzbzdnov
Цитата:

Цитата: worksheet с русским текстом в файл, чтобы в файле получился оттабулированный текст

FileFormat := xlTextWindows (Текстовые файлы с разделителями табуляции)

Доброго всем утра.
Очередной раз обращаюсь за помощью в надежде, что вы разрешите мою проблему.
Дело в том, что у меня есть файл, который содержит информацию об изменениях вносимых в бюджеты филиалов (для каждого отдельный лист). Нельзя ли сделать так, чтобы вводимая в филиалах информация автоматически переносилась в сводную таблицу этой же книги? Таблица выглядит так:
Основание №корр. Дата Iкв. IIкв. IIIкв. IVкв.

giash
для начала посмотрите в этом топике 20-22.12.2006 от Gtto было обсуждение подобной проблемы. Если не разберётесь - пишите сюда - только побольше конкретики - что нужно переносить, откуда и куда... Ручками вы это можете сделать? тогда сможете и объяснить. Плюс неплохо бы выложить файлик-пример...
ДА и ещё - перенос (физически) данных, в отличии от формул - не будет меняться, если вдруг изменяться данные в исходных файлах...

SERGE_BLIZNUK

Цитата:

Только я не представлял (и не представляю пока) как это можно получить без VBA - только с помощью формул...

Да я и сам раньше не представлял, как много можно сделать не прибегая к помощи VBA, пока не наткнулся у буржуев на формулу для выдирания униальных значений из массива.

Цитата:

задача просто "просится" быть запрограммированной с помощью СУБД

Жаль, я до понедельника занят - а то руки чешутся эту задачу через формулы сделать. - Будет хороший опыт.

giash

Цитата:

Нельзя ли сделать так, чтобы вводимая в филиалах информация автоматически переносилась в сводную таблицу этой же книги?

А через формулы не пробовал? На листе с итоговой таблицей можно же сделать формулы, ссылающиейся на данные в других листах.


Цитата:

файл на который мы ссылаемся должен быть обязательно открыт,

Он должен быть открыт (если и должен), только когда ты меняешь ссылку.

Цитата:

Мне то ничего, но вот моим сотрудницам, которым уже за 50-т разобраться во всем этом будет не легко.

Боюсь, "сотрудницам, которым уже за 50" разобраться будет не легко, даже если форму сделать для выбора файла.

Цитата:

Исходя из этого нет ли иного решения данной проблемы?

А что было нужно сделать?

Код: Private Sub OK_Click()
Dim strDate As String
strDate = Format(Now(), "dd.mm")
If Sheets(1).Name <> strDate Then
ActiveSheet.Copy Before:=Sheets(1)
Sheets(1).Select
Sheets(1).Name = strDate
End If
Sheets(1).Select
Sheets(1).Name = strDate
Range("E3:E25", "E27:E31").Value = Range("AD3:AD25", "AD27:AD31").Value
Range("F3:AD25", "F27:AD31").ClearContents
Range("AL23:AQ28").ClearContents
For Each s In Worksheets(1).Shape
If s.Type = msoOLEControlObject Then
If InStr(s.OLEFormat.progID, "ToggleButton") > 0 Then
s.OLEFormat.Object.Object.Value = False
End If
End If
Next
End Sub

alin

Цитата:

"Run time error '9'. Subscript out of range"

Значит VBA чего-то не нашел и у тебя в коде строка с этим "чем-то" выделилась желтым. В этой строке программа обращается к элементу коллекции, которого нет.

to The OKK
Цитата:

А через формулы не пробовал? На листе с итоговой таблицей можно же сделать формулы, ссылающиейся на данные в других листах.

Скорее всего, моих познаний Excel-а недостаточно для подбора формулы. Проблема в том, что данные в листах содержащих информацию по филиалам будут постоянно добавляться (начиная с основания и заканчивая суммой) и я не понимаю каким образом переносить новую информацию в сводную табличку. Логика здесь такая: сводная пробегается по листам филиалов сверяет данные имеющиеся в них со своими и в случае необходимости добавляет новую запись в себя. Топорно я сделал это следующим образом, просто ввел последовательно с запасом ссылки на различные листы книги, а в сводной дал в фильтре не равно 0. Все бы хорошо, но только чтобы увидеть новую запись надо заново дать условие в фильтре. в общем, как-то не симпатично получается.
с уважением

giash
Цитата:

чтобы увидеть новую запись надо заново дать условие в фильтре

так может в этом и есть ключ к решению? на открытие вашего документа код в VBA, который проверяет доп.листы и при необходимости корректирует фильтр?...

The okk
На эту строчку указывает, но уже другая ошибка:

Код: For Each s In Worksheets(1).Shape

alin

Цитата:

For Each s In Worksheets(1).Shape

For Each s In Worksheets(1).Shapes

to SERGE_BLIZNUK

Цитата:

так может в этом и есть ключ к решению?на открытие вашего документа код в VBA, который проверяет доп.листы и при необходимости корректирует фильтр

Абсолютно с вами согласен. Но, к сожалению, создание кода выходит за рамки моих возможностей. Увы...

Troitsky
Да, действительно, именно этого и не хватало!

Troitsky
The okk
Yuk
Спасибо Вам Всем За Помощь!