День добрый. Не могу справиться с сохранением кода в другой проект. Код переносится, но при закрытии книги не сохраняется. Подскажите пожалуйста, что делаю не так?
Скрытый текст
With ActiveWorkbook Set oWb = .VBProject Set compon = oWb.VBComponents("Ëèñò" & kSh) Set modul = compon.codemodule 'âñòàâëÿåì êîä str = ThisWorkbook.VBProject.VBComponents(26).codemodule.Lines(2, 28) compon.codemodule.InsertLines 29, str .SaveAs Filename:="\\SERVER\common\Ñêëàäû, öåíû è ïð\ÏîèñêÖåíû.xls", FileFormat:=xlExcel8 .Close False End With
Добрый день. Никак не могу определить, из-за чего Find упорно не находит в ячейке R17C20 искомое? Предполагаю, что на вашем ПК макрос будет срабатывать, поэтому покажу скрин.
Добрый вечер. 1.На первом листе исходные данные, с меткой "Уникальное". Беру диапазон от "Уникального" до ближайщего "Уникального". 2.Выделяю уникальные и сортирую по алфавиту. 3. А вот закинуть tbl в Redim что-то не получается.
Ребята, подскажите пожалуйста, где я ошибаюсь при выводе массива на лист "готово".
Макрос тут
Код
Sub ArrUniqSort()
Dim Uniq As New Collection, i&, ii&, iii&, iiii&, y&, n&, s, b As Range, a&
Dim x, tbl, arr, lstr&, c&
Application.ScreenUpdating = False
lstr = Cells(Rows.Count, 1).End(xlUp).Row
c = Application.WorksheetFunction.CountIf(Range("F1:F" & lstr), "Уникальное")
With Worksheets(1).Range("F1:F" & lstr)
Set b = .Find("Уникальное", , xlValues, xlPart)
If Not b Is Nothing Then
For i = 1 To c
a = b.Row
Set b = .FindNext(b)
If i = c Then
Set arr = Range("A" & a & ":F" & lstr)
Else
Set arr = Range("A" & a & ":F" & b.Row - 1)
End If
For n = 1 To 5 ' дапазон столбцов, где ищем уникальные
For ii = 1 To arr.Rows.Count ' дапазон строк, где ищем уникальные
On Error Resume Next
Uniq.Add arr(ii, n), CStr(arr(ii, n)) ' создаём item уникальных
Next
Next
ReDim arr(1 To Uniq.Count)
For iii = 1 To Uniq.Count
arr(iii) = Uniq(iii) 'из item переводим уникальные в value
Next
On Error Resume Next
With New Collection 'создание коллекции для сортировки value
For Each x In arr
If Len(x) > 0 Then 'пустые значения игнорируем
If IsEmpty(.Item(x)) Then 'пустые значения игнорируем
For iiii = 1 To .Count
If x < .Item(iiii) Then Exit For
Next
If iiii > .Count Then
.Add x, x
Else
.Add x, x, Before:=iiii 'сортировка по алфавиту
End If
End If
End If
Next
ReDim tbl(1 To 1, 1 To .Count)
For iiii = 1 To .Count
tbl(i, iiii) = .Item(iiii)
Next
Sheets("готово").Range("A" & i).Resize(1, .Count).Value = tbl
End With
Next
End If
End With
Application.ScreenUpdating = True
End Sub
Изменено: Владимир - 03.02.2017 16:11:03(Накидал.Перезалил)
"..Сладку ягоду рвали вместе, горьку ягоду я одна."
Добрый день. Ребята, помогите пожалуйста разобраться с методом Union. Пытаюсь создать одну таблицу из двух - Uninon(arr1,arr2). В Locals вижу, что Count стал 51, что есть ИСТИНА, а вот увидеть вторую таблицу нигде не могу. Чего я не так делаю?
"..Сладку ягоду рвали вместе, горьку ягоду я одна."
Доброе утро. Подскажите пожалуйста, как по имени файла определить, какой должен запуститься макрос. Все макросы находятся в Personal.xlsb.
Код
Private Sub ExportToOneC()
Dim nakl, mcrs, i&
Application.ScreenUpdating = False
Application.DisplayAlerts = False
nakl = Array("уфOДИ*", "УПД RSP*", "t-*")' накладные приходящие от поставщиков (имена переменные)
mcrs = Array("Партком", "Шате_М", "AvtokorOpt")' имя макрос
With ActiveWorkbook
For i = 0 To UBound(nakl)
If .Name Like nakl(i) Then
Call mcrs
Exit For
End If
Next
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
"..Сладку ягоду рвали вместе, горьку ягоду я одна."
Добрый день, уважаемые Планетяне. Копирую из браузера исходный текст, для того чтобы вытащить оттуда свои заказы. Но текст больше, чем вмещает в себя ячейка. Остаток исходного текста, который не влез в F1, поместил в G1. Написал макрос, который ссылается на ячейку F1 и через Call на ячейку G1. Но мне кажется, что данное решение неправильно - есть подозрение, что придётся заполнять и 3-ю ячейку. А вот мыслей умных у меня нет. Может кто-то что-то дельное подскажет по алгоритму?
"..Сладку ягоду рвали вместе, горьку ягоду я одна."
Добрый вечер. Нашёл на просторах Планеты макрос, который показывает в ListBox_e найденное по первым буквам, введённым в TextBox_е. Но мне немного этого мало. Хочется, когда в ListBox_e появляются предложения выбрать одно из них мышкой, после чего в столбце С появится текущий статус данной детали. Исходные данные находятся на листе2.
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(min)
.Item(min(i, 8)) = min(i, 4)
If min(i, 4) = 0 Then .Item(min(i, 8)) = min(i, 4).Interior.ColorIndex = 3
Next
For i = 1 To UBound(ZkPk)
.Item(ZkPk(i, 4)) = CStr(Mid(ZkPk(i, 1), 22, 3))
Next
For i = 1 To UBound(isk)
If .exists(isk(i, 1)) Then
isk(i, 1) = .Item(isk(i, 1))
Else
isk(i, 1) = Empty
End If
Next
End With
Изменено: Владимир - 12.02.2016 09:39:25(Блин, как сообщение-то само отправить??? Не даёт выйти из кода..)
"..Сладку ягоду рвали вместе, горьку ягоду я одна."
Добрый вечер. В конце макроса строкой AllCells.Select нахожу те ячейки, которые мне нужно удалить со сдвигом вверх. Но прежде чем их удалить, хочу расширить выделение на 3 столбца вправо, т.к. удаляя строку удалю и условие для фильтров, которые будут находится справа (в примере условия находятся внизу - столбец 7). Подскажите пожалуйста, возможно ли это сделать?
"..Сладку ягоду рвали вместе, горьку ягоду я одна."
Добрый день. Подскажите пожалуйста алгоритм. Как найти последнюю накладную поставки по каждому артикулу запчасти. Не по дате последнюю, а последнюю в списке. В примере в столбце В формула, которая правильно находит необходимую дату. А вот как это реализовать макросом, даже близко не представляю. UDF не нужно.
Спасибо.
"..Сладку ягоду рвали вместе, горьку ягоду я одна."
Добрый вечер. Есть диапазон isx=range("a1:c30").value, как можно определить кол-во значений в третьем столбце, исходя уже из существующей ссылки - isx? Что-то типа такого - isx( ,3).count
Спасибо.
"..Сладку ягоду рвали вместе, горьку ягоду я одна."
Добрый день. Таблица после обновления сократилась в строках. Но в окне immediate видно (sheets(1).usedrange.rows.select), что её размеры сохранились. Решил почистить отработанные строки, т.е. удалить разность между usedrange - cells(rows.Count,2).end(xlup).row Пищу rows(cells(rows.Count,2).end(xlup).row+1&":"&sheets(1).usedrange.rows.count).delete Shift:=xlUp, но орфографию макросов слабо пока понимаю, поэтому не могу составить диапазон удаляемых строк. Подскажите, люди добрые, где ошибаюсь?
"..Сладку ягоду рвали вместе, горьку ягоду я одна."
Ребята, подскажите пожалуйста, можно ли ? Пример: =ЕСЛИ(A1:A10="иванов";B1:B10) через F9 будет такой диапазон - {1:ЛОЖЬ:ЛОЖЬ:ЛОЖЬ:ЛОЖЬ:6:7:ЛОЖЬ:ЛОЖЬ:ЛОЖЬ} А как макросом создать такой диапазон, чтобs он появился в Locals?
"..Сладку ягоду рвали вместе, горьку ягоду я одна."
avl = ChPoZak.Sheets(6).[A2].CurrentRegion.Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(avl) .Item(avl(i, 1)) = i Next ReDim c(1 To UBound(aa), 1 To 1) ' For i = 1 To UBound(aa) If .exists(aa(i, 1)) Then ii = .Item(aa(i, 1)) c(i, 1) = avl(ii, 3) End If Next End With [H8].Resize(i - 1) = c()
ix = ChPoZak.Sheets(5).[A3].CurrentRegion.Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(ix) .Item(ix(i, 1)) = i Next ReDim c(1 To UBound(aa), 1 To 1) ' For i = 1 To UBound(aa) If .exists(aa(i, 1)) Then ii = .Item(aa(i, 1)) c(i, 1) = ix(ii, 6) End If Next End With [G8].Resize(i - 1) = c()
ak = ChPoZak.Sheets(7).UsedRange.Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(ak) .Item(ak(i, 1)) = i Next ReDim c(1 To UBound(aa), 1 To 1) For i = 1 To UBound(aa) If .exists(aa(i, 1)) Then ii = .Item(aa(i, 1)) c(i, 1) = ak(ii, 15) End If Next End With [I8].Resize(i - 1) = c()
min = ChPoZak.Sheets(4).[B2].CurrentRegion.Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(min) .Item(min(i, 8) = i Next ReDim c(1 To UBound(aa), 1 To 2) For i = 1 To UBound(aa) If .exists(aa(i, 1)) Then ii = .Item(aa(i, 1)) c(i, 1) = min(ii, 5) If c(i, 2) = 0 Then min(ii, 6) = "" Else c(i, 2) = min(ii, 6) End If End If Next End With [J8:K8].Resize(i - 1) = c()
Columns(12).ClearContents zak = ChPoZak.Sheets(2).UsedRange.Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(zak) ' последняя строка исх.таблицы .Item(zak(i, 1)) = i ' заносим в словарь код Next ReDim c(1 To UBound(aa), 1 To 1) ' создаём размер итоговой таблицы For i = 1 To UBound(aa) If .exists(aa(i, 1)) Then ii = .Item(aa(i, 1)) If Application.Sum(Cells(i + 7, 10), Cells(i + 7, 11)) < Val(Cells(i + 7, 4)) Then c(i, 1) = zak(ii, 6) End If End If Next End With [L8].Resize(i - 1) = c()
pr = ChPoZak.Sheets(8).UsedRange.Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(pr) .Item(CStr(pr(i, 1))) = i Next ReDim c(1 To UBound(aa), 1 To 1) For i = 1 To UBound(aa) If .exists(aa(i, 1)) Then ii = .Item(aa(i, 1)) c(i, 1) = pr(ii, 15) End If Next End With [F8].Resize(i - 1) = c() Range("F5:K5").Copy Range("F8:K" & lstr).PasteSpecial Paste:=xlPasteFormats Range("J8:K" & lstr).HorizontalAlignment = xlRight sel = 7 + Selection.Rows.Count Range(Cells(sel + 1, 5), Cells(sel + 100, 12)).Clear ChPoZak.Saved = True Application.CutCopyMode = False Application.ScreenUpdating = True End Sub
У меня постоянно выскакивает данная ошибка, когда открыт исходный файл. Если его закрыть, то макрос отрабатывает нормально. В чём может быть причина? Может уйти от GetObject?
"..Сладку ягоду рвали вместе, горьку ягоду я одна."
Вечер добрый. Делаю ссылку на диапазон - Set x1 = Range(Cells(17, 2), Cells(Cells(17, 2).End(xlDown).Row - 1, 2)) и сразу вижу в окне Locals, что он из текстового формата превращается в числовой. Т.е. когда впереди кода идут нули, к примеру 0450000400, то они обрубаются - 450000400. А это не есть хорошо, мне бы зафиксировать их "045000.." Подскажите пожалуйста, как сохранить текстовой формат, чтобы при выгрузке видно было такой же формат - 0450000400.
"..Сладку ягоду рвали вместе, горьку ягоду я одна."
Добрый день. Как делать заливку в цикле знаю, а как в словаре - близко не представляю. 1.В примере хочу закрасить зелёным цветом столбец А, при условии, что в столбце D данные от 50 до 100. И красным, если менее нуля.
2.Что для быстродействия макроса и веса файла более комфортно - красить в макросе или стандартным УФ-ом?
Спасибо.
"..Сладку ягоду рвали вместе, горьку ягоду я одна."
Здравствуйте. Вставляю данные макросом, но они встают на 3 ячейки ниже. Лишь один регулятор нашёл вместо F4 поставить F1, но тогда у меня попадает на заголовок таблицу. Подскажите пожалуйста, где подставить -3, чтобы данные оказались на своём месте? Всё перепробовал "тыком", везде ошибку выдаёт.
Код
b = Sheets(6).UsedRange.Value ' таблица, в которой ищем
With CreateObject("Scripting.Dictionary")
For ix = 1 To UBound(b) ' последняя строка исх.таблицы
.Item(b(ix, 1)) = ix ' заносим в словарь код
Next
aa = Sheets(1).UsedRange.Columns(16).Value ' диапазон, который ищем
ReDim c(1 To UBound(aa), 1 To 1) ' создаём размер итоговой таблицы
For ix = 1 To UBound(aa)
If .exists(aa(ix, 1)) Then
ii = .Item(aa(ix, 1))
c(ix, 1) = b(ii, 3)
End If
Next
End With
Sheets(1).[F4].Resize(ix) = c()
"..Сладку ягоду рвали вместе, горьку ягоду я одна."
Добрый день. Подскажите, что может Do...Loop такого, что нельзя сделать при помощи For...Next или If, или иного оператора? Никогда на ум не приходит использовать Do...Loop. Может я неправ?
"..Сладку ягоду рвали вместе, горьку ягоду я одна."
Здравствуйте. Учусь работать с массивами. Хочу вытащить непустые значения из столбца А:А. Получилось, но только при помощи удаления пустых строк. А как можно сделать тоже самое, только без удаления строк?
Спасибо.
"..Сладку ягоду рвали вместе, горьку ягоду я одна."
Здравствуйте. Подскажите пожалуйста, как избавиться от ошибки. Если файл открыт, то не отрывать, если закрыт, то Workbooks.Open FileName:="F:\Логистика\Книга.XLSM"
"..Сладку ягоду рвали вместе, горьку ягоду я одна."
Добрый день. Пытаюсь написать макрос по удалению строк при условии - Cells(i, 16) >= Cells(i + 1, 3). Если условие ИСТИНА, то должны удалится три строки - Range(Cells(i, 2), Cells(i + 2, 2)).EntireRow.Delete. Подскажите, пожалуйста, что неправильно делаю?
"..Сладку ягоду рвали вместе, горьку ягоду я одна."