Евгений, нужно в Настеном файле в модуле формы (UserForm1) найти фразы ActiveCell.Formula и заменить их на ActiveCell.FormulaLocal В приложенном файле от Насти я уже это заменил, можете взять этот файл
Равик, у Range и Cells обязательно нужно указывать родителя (лист), кроме случаев когда вы работаете с Активным листом (тогда ничего не надо указывать). В вашей строке код у Cells не указан родитель, поэтому Cells обращается к активному листу
Вот 2 варианта правильного указания родителя у Range и Cells (напомню, это очень важно, если вы работаете НЕ с активным листом) 1-й вариант более длинный, второй более короткий, но обязательно нужно ставить точки перед Range и Cells
Код
Sub test()
'ВАРИАНТ 1
Set OOOstatkiCopy = Workbooks("Общие остатки.xlsx").Worksheets("Stock") _
.Range(Workbooks("Общие остатки.xlsx").Worksheets("Stock").Cells(UpperCellRow, 3), _
Workbooks("Общие остатки.xlsx").Worksheets("Stock").Cells(OOlRow, 3))
'ВАРИАНТ 2
With Workbooks("Общие остатки.xlsx").Worksheets("Stock")
Set OOOstatkiCopy = .Range(.Cells(UpperCellRow, 3), .Cells(OOlRow, 3))
End With
End Sub
mymail, добавил такую функцию для формы - при нажатии клавиши Escape форма закрывается.
Это будет удобно, когда вам надо проверить ваш текст, но менять, например, ничего не стали, нажимаете Escape и форма закроется (просто чтобы мышкой не нажимать кнопку Отмена на форме)
В моем файле вам надо зайти в модуль Лист1 и скопировать тот код в модуль вашего листа в своем файле. да-да, код может быть не только в Module1 и UserForm, код так же может быть в модуле каждого листа. так же нажмите, как обычно, Alt+F11, и 2 раза щёлкните на модуле Лист1 и увидите код. Его и скопируйте в модуль листа с данными в вашей книге
заменять ничего в формуле не надо. Надо из 1-го столбца удалить Проверку данных, в ячейку А2 вставить эту формулу и протянуть вниз и по идее будет то, что вы хотели - вводите во 2-м столбце цвет и в 1-м столбце он отобразится или же будет пусто
Добработаю формулу от Сергей, чтобы было пусто, когда цвет не найден
Код
=ЕСЛИОШИБКА(ВПР(B2;name55;1;0);"")
P.S. Понимаете... я всю жизнь закупаю из Китая то канцелярию, то наушники, кабели, зарядки, чехлы, чайники, пылесосы, телефоны и т.д.... Мало интересный товар... а вот думал всегда - кто-то же закупает интересный "товар" ))
OFFTOPIC Ураа, я наконец-то нашёл живого человека, кто занимается этим "товаром")) А я всё думал - ну, кто-то же должен закупать, анализировать такой "товар" )) P.S. Завидую )
По теме - а какой смысл вбивать цвет во втором столбце и чтоб он выбирался в первом столбце? Можно конечно макрос написать... он будет переносить введённый вами цвет из 2-го столбца в 1-й
В структуре файла есть xml файл CustomUI.xml там и прописано добавлять пункт в контекстное меню. Чтобы посмотреть этот файл смените расширение xlam на zip. Откройте архив там будет папка CustomUI, а в ней этот файл xml Так же ссылка на этот файл есть в файле из папки _rels
Ну, Сергей... пришлось почти весь код переписывать) См. файл.
P.S. А зачем вы 3-й лист с которого надо брать данные назвали вот так "04-15-01-М291-М-29" - тут нет сочетания М-291 (М291 не равно М-291)
Вот сам код
Код
Sub Перенести_материалы_на_Форму230()
Dim Sht As Worksheet, Rng As Range, arrData, lastCol As Long, counter As Long, i As Long, lastRowBazaSht As Long
Dim BasaSht As Worksheet, PererashodRow As Long, SheetsCount As Long
If MsgBox("Собрать данные с листов в Форму-230?", vbQuestion + vbYesNo, "Вопрос") = vbNo Then Exit Sub
Set BasaSht = Worksheets("ФОРМА-230") 'лист куда будем собирать все данные
'цикл по всем листам в файле
For Each Sht In ThisWorkbook.Worksheets
'если название листа содержит М-291
If Sht.Name Like ["*М-291*"] Then
SheetsCount = SheetsCount + 1 'счётчик обработанных листов
With Sht
'номер строки с "Итого: расход по норме"
Set Rng = .Cells.Find("Итого: расход по норме", , xlFormulas, xlWhole)
If Rng Is Nothing Then
MsgBox "На листе " & Sht.Name & " не найдена ячейка 'Итого: расход по норме'!", vbExclamation, "Внимание"
Exit Sub
End If
PererashodRow = Rng.Row
Set Rng = .Cells.Find("Наименование материалов", , xlFormulas, xlWhole)
If Rng Is Nothing Then
MsgBox "На листе " & Sht.Name & " не найдена ячейка 'Наименование материалов'!", vbExclamation, "Внимание"
Exit Sub
End If
'номер столбца с последними данными (с последним материалом)
lastCol = .Cells(Rng.Row + 1, .Columns.Count).End(xlToLeft).Column
'определяем размер массива под заполнение данными
ReDim arrData(1 To ((lastCol - Rng.Column) / 2) + 1, 1 To 4)
counter = 0
For i = Rng.Column To lastCol
If Not IsEmpty(.Cells(Rng.Row + 1, i)) Then
counter = counter + 1
arrData(counter, 1) = .Cells(Rng.Row + 1, i) 'название материала
arrData(counter, 4) = .Cells(PererashodRow, i + 1) 'расход по норме
End If
Next i
End With
'выгрузка данных на лист ФОРМА-230
With BasaSht
Set Rng = .Cells.Find("Наименование материала", , xlFormulas, xlWhole)
If Rng Is Nothing Then
MsgBox "На листе " & BasaSht.Name & " не найдена ячейка 'Наименование материала'!", vbExclamation, "Внимание"
Exit Sub
End If
lastRowBazaSht = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
.Cells(lastRowBazaSht, 1).Resize(UBound(arrData), 4).Value = arrData
End With
End If
Next Sht
MsgBox "Сбор данных завершён!" & vbNewLine & "Данные собраны с " & SheetsCount & " листов", vbInformation, "Конец"
End Sub
Игнорировать можно хоть все) можно например, проверять, если название листа содержит "Лист", то берём с него данные. А разные другие листы с другими названиями игнорируем
Всё можно. Только нужно придумать какой-нибудь обход. Для примера, лист куда мы копируем назвать не просто как у вас "Лист2", а например, "Отчёт", то в макросе можно прописать цикл по всем листам в файле, игнорируя лист Отчёт. Если так подойдёт, то в вашем файле переименуйте Лист2 на Отчёт, и добавьте 2-3 листа с которых мы будем брать данные (это чтобы я тестировал свой макрос), а я вечером доработаю макрос под ваш пример. Макрос будет брать данные со всех листов, кроме листа Отчёт. И тогда не важно сколько будет листов в файле, хоть 100, макрос будет с них переносить данные в лист Отчёт
Сергей, в вашем файле нет листа с названием "Лист", в файле есть листы "Лист1", "Лист2", "Лист3" Жёлтые ячейки есть на "Лист2" и на "Лист3". А что делать с "Лист1" и таблицей на ней? Вам надо жёлтые ячейки с "Лист3" перенести на "Лист2" ?
P.S. ну, почему люди выкладывают файл с примером и пишут - посмотрите лист "Заказ". Открываешь файл, а там нет листа "Заказ", но есть другие 5 листов, которые не имеют к вопросу никакого отношения.... я буду в Гаагу жаловаться!
Перебор нескольких изменяемых параметров данных и запись всех результатов в новые таблицы., при изменяемых исходных данных нужно получить ВСЕ варианты решений
Годы практики )) Ну, я ещё не научился телепатии по нику человека определять его профессию) Поэтому всем всегда объясняю как "чайникам", а то ответишь коротко, а потом начинается - а у меня не получается, а куда нажать, а где эта кнопка... и тд.) На мой взгляд тут ничего не нужно у вас переводить в циклы. На всякий случай выложу ваш код сюда, может другие люди подскажут. Меня смущают ваши таймеры ожидания "в пол-секунды", думаю они не нужны. но и не думаю, что они сильно мешают.
Код
Sub Count1()
Rem подставляем 3 исходных коэффициента для формул
Worksheets("SAR").Range("R2").Copy Worksheets("Results").Range("B3")
Worksheets("SAR").Range("R2").Copy Worksheets("Main").Range("B21")
Worksheets("SAR").Range("S2").Copy Worksheets("Results").Range("C3")
Worksheets("SAR").Range("S2").Copy Worksheets("Main").Range("B22")
Worksheets("SAR").Range("T2").Copy Worksheets("Results").Range("D3")
Worksheets("SAR").Range("T2").Copy Worksheets("Main").Range("B23")
Rem копируем 1й промежуточный коэффициент из другого места
Worksheets("Results").Range("A5").Copy Worksheets("Main").Range("B27")
Rem ждем пол-секунды, пока Excel произведет расчеты
Application.Wait Now + TimeSerial(0, 0, 0.2)
Rem записываем 1й ряд результатов итоговой таблицы № 1
Worksheets("Main").Range("H22").Copy
Worksheets("Results").Range("B5").PasteSpecial Paste:=xlPasteValues
Worksheets("Main").Range("H23").Copy
Worksheets("Results").Range("C5").PasteSpecial Paste:=xlPasteValues
Worksheets("Main").Range("H27").Copy
Worksheets("Results").Range("D5").PasteSpecial Paste:=xlPasteValues
Worksheets("Main").Range("H19").Copy
Worksheets("Results").Range("E5").PasteSpecial Paste:=xlPasteValues
Rem копируем 2й промежуточный коэффициент из другого места
Worksheets("Results").Range("A6").Copy Worksheets("Main").Range("B27")
Rem ждем пол-секунды, пока Excel произведет расчеты
Application.Wait Now + TimeSerial(0, 0, 0.2)
Rem записываем 2й ряд результатов итоговой таблицы № 1
Worksheets("Main").Range("H22").Copy
Worksheets("Results").Range("B6").PasteSpecial Paste:=xlPasteValues
Worksheets("Main").Range("H23").Copy
Worksheets("Results").Range("C6").PasteSpecial Paste:=xlPasteValues
Worksheets("Main").Range("H27").Copy
Worksheets("Results").Range("D6").PasteSpecial Paste:=xlPasteValues
Worksheets("Main").Range("H19").Copy
Worksheets("Results").Range("E6").PasteSpecial Paste:=xlPasteValues
Rem копируем 3й промежуточный коэффициент из другого места
Worksheets("Results").Range("A7").Copy Worksheets("Main").Range("B27")
Rem ждем пол-секунды, пока Excel произведет расчеты
Application.Wait Now + TimeSerial(0, 0, 0.2)
Rem записываем 3й ряд результатов итоговой таблицы № 1
Worksheets("Main").Range("H22").Copy
Worksheets("Results").Range("B7").PasteSpecial Paste:=xlPasteValues
Worksheets("Main").Range("H23").Copy
Worksheets("Results").Range("C7").PasteSpecial Paste:=xlPasteValues
Worksheets("Main").Range("H27").Copy
Worksheets("Results").Range("D7").PasteSpecial Paste:=xlPasteValues
Worksheets("Main").Range("H19").Copy
Worksheets("Results").Range("E7").PasteSpecial Paste:=xlPasteValues
Rem копируем 4й промежуточный коэффициент из другого места
Worksheets("Results").Range("A8").Copy Worksheets("Main").Range("B27")
Rem ждем пол-секунды, пока Excel произведет расчеты
Application.Wait Now + TimeSerial(0, 0, 0.2)
Rem записываем 4й ряд результатов итоговой таблицы № 1
Worksheets("Main").Range("H22").Copy
Worksheets("Results").Range("B8").PasteSpecial Paste:=xlPasteValues
Worksheets("Main").Range("H23").Copy
Worksheets("Results").Range("C8").PasteSpecial Paste:=xlPasteValues
Worksheets("Main").Range("H27").Copy
Worksheets("Results").Range("D8").PasteSpecial Paste:=xlPasteValues
Worksheets("Main").Range("H19").Copy
Worksheets("Results").Range("E8").PasteSpecial Paste:=xlPasteValues
Rem копируем 5й промежуточный коэффициент из другого места
Worksheets("Results").Range("A9").Copy Worksheets("Main").Range("B27")
Rem ждем пол-секунды, пока Excel произведет расчеты
Application.Wait Now + TimeSerial(0, 0, 0.2)
Rem записываем 5й ряд результатов итоговой таблицы № 1
Worksheets("Main").Range("H22").Copy
Worksheets("Results").Range("B9").PasteSpecial Paste:=xlPasteValues
Worksheets("Main").Range("H23").Copy
Worksheets("Results").Range("C9").PasteSpecial Paste:=xlPasteValues
Worksheets("Main").Range("H27").Copy
Worksheets("Results").Range("D9").PasteSpecial Paste:=xlPasteValues
Worksheets("Main").Range("H19").Copy
Worksheets("Results").Range("E9").PasteSpecial Paste:=xlPasteValues
Rem копируем 6й промежуточный коэффициент из другого места
Worksheets("Results").Range("A10").Copy Worksheets("Main").Range("B27")
Rem ждем пол-секунды, пока Excel произведет расчеты
Application.Wait Now + TimeSerial(0, 0, 0.2)
Rem записываем 6й ряд результатов итоговой таблицы № 1
Worksheets("Main").Range("H22").Copy
Worksheets("Results").Range("B10").PasteSpecial Paste:=xlPasteValues
Worksheets("Main").Range("H23").Copy
Worksheets("Results").Range("C10").PasteSpecial Paste:=xlPasteValues
Worksheets("Main").Range("H27").Copy
Worksheets("Results").Range("D10").PasteSpecial Paste:=xlPasteValues
Worksheets("Main").Range("H19").Copy
Worksheets("Results").Range("E10").PasteSpecial Paste:=xlPasteValues
End Sub
Акмал Мухитдинов, данный макрос не запускается человеком. Данный макрос находится в модуле какого-то одного листа и отслеживает изменение выделения ячеек. Как только вы выделяете ячейку в 3-м столбце сразу макрос начинает работать
Перебор нескольких изменяемых параметров данных и запись всех результатов в новые таблицы., при изменяемых исходных данных нужно получить ВСЕ варианты решений
ADFF написал: Я пока даже не смог скопировать текст из окна редактора в блокнот... Мда... Кракозябры там получаются, а как кодировку править - не нашел.
1. перед копированием (перед тем как нажать Ctrl+C) в редакторе кода переключитесь на русский язык (у меня на компе это левый ALT+Shift), чтобы в правом нижнем углу экрана (где часики) у вас было написано RU, а не EN и дальше копируйте - никаких "кракозяблей" не будет
2. Вместо слова "REM" в модуле можете ставить апостроф и писать дальше ваш комментарий. Апостроф это знак ' (на английском языке русская буква Э на клавиатуре)
Код
Sub Test()
' вот мой комментарий с апострофом в начале строки
End Sub
3. В самом начале вашего кода перед первым копированием добавьте строку
Код
Application.ScreenUpdating = False
а после последнего копирования добавьте строку
Код
Application.ScreenUpdating = True
это отключит визуализацию на время выполнения макроса, т.е. экран замрёт на время выполнения макроса. Так лучше и макрос быстрее выполняется
Sub Макрос1()
Dim lastRow As Long
Worksheets("Sheet3").Columns(1).Clear 'вот тут вместо Cells вписал Columns(1)
With Worksheets("Sheet1")
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range(.[A1], .Cells(lastRow, 1)).Copy Worksheets("Sheet3").Range("A1")
End With
With Worksheets("Sheet2")
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range(.[A2], .Cells(lastRow, 1)).Copy Worksheets("Sheet3").Cells(Worksheets("Sheet3").Cells(.Rows.Count, 1).End(xlUp).Row, 1)
End With
With Worksheets("Sheet3")
.Range("A1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes 'удаляем дубли
.Range("A1").CurrentRegion.Sort .Cells(1, 1), xlAscending, Header:=xlYes 'сортируем
End With
MsgBox "Сделано!", vbInformation, "Конец"
End Sub
Перебор нескольких изменяемых параметров данных и запись всех результатов в новые таблицы., при изменяемых исходных данных нужно получить ВСЕ варианты решений
Игорь, а зачем ArrayList? Может просто скопировать два списка один под другим, удалить дубликаты и отсортировать его по возрастанию, не? Я имею ввиду вот так
Код
Sub Макрос1()
Dim lastRow As Long
Worksheets("Sheet3").Cells.Clear
With Worksheets("Sheet1")
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range(.[A1], .Cells(lastRow, 1)).Copy Worksheets("Sheet3").Range("A1")
End With
With Worksheets("Sheet2")
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range(.[A2], .Cells(lastRow, 1)).Copy Worksheets("Sheet3").Cells(Worksheets("Sheet3").Cells(.Rows.Count, 1).End(xlUp).Row, 1)
End With
With Worksheets("Sheet3")
.Range("A1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes 'удаляем дубли
.Range("A1").CurrentRegion.Sort .Cells(1, 1), xlAscending, Header:=xlYes 'сортируем
End With
MsgBox "Сделано!", vbInformation, "Конец"
End Sub
Перебор нескольких изменяемых параметров данных и запись всех результатов в новые таблицы., при изменяемых исходных данных нужно получить ВСЕ варианты решений
ADFF, Дополню чуть код от buchlotnik добавив в него отключение визуализации. Код будет работать чуть быстрее.
Код
Sub g()
Application.ScreenUpdating = False 'добавил
For i = 1 To 10
[H5] = [B3].Offset(i, 0)
For j = 1 To 10
[I5] = [C3].Offset(j, 0)
For k = 1 To 10
[J5] = [D3].Offset(k, 0)
Application.Calculate
r = r + 16
[G4:J18].Copy
[G4].Offset(r, 0).PasteSpecial xlPasteValues
Next k
Next j
Next i
Application.ScreenUpdating = True 'добавил
MsgBox "Done!"
End Sub
Попробуйте формулу ВПР() К большой таблице подтяните данные из маленькой Если сложно, то выложите небольшой пример в Excel файле, мы вам сами вставим формулу в ячейку и протянем