Здравствуйте! Прошу помочь с переработкой макроса для рабочей деятельности под Luo, так как с этим языком не знаком. Спасибо за помощь! Прикрепляю макрос в документах.
Здравствуйте. Прошу подсказать в улучшении (упрощении) макроса, использую его для переворота таблиц. В чем суть переворота: 1) В каждую таблицу добавляется столбец с помощью одного из макросов, куда в дальнейшем переносится название листа и протягивается на всю длину столбца где есть данные (листов в документах от 60 до 90 - каждый документ по разному) 2) А затем происходит переворот другим макросом В примере привел пример, как выглядит исходник, потом после добавление столбца и в итоговом виде. Примечание:1) Количество строк в каждом листе отличается от 2 до 20 (это примерно) - каждый раз по разному 2) Количество листов тоже меняется в каждом документе 3) Шапка всегда тоже меняется, все зависит от базы (поэтому макрос при перевороте спрашивает сколько столбцов и строк нужно) Буду благодарен любой помощи!
Приветствую, прошу помочь с решением проблемы с макросом. Условие: есть таблица на 100 листов ( примерно), каждый лист имеет свой код уникальный (название листа) и каждый лист по структуре одинаковый, только данные внутри таблицы разные. Нужно:
Сделать редизайн таблицы, как приведено в примере, всех листов
Перенести номер листа в таблицу в столбец и протянуть на всю длину таблицы
Привожу мой код, он только переносит один столбец, а второй удаляет.... Спасибо большое за помощь!
Код
Sub НазваниеЛистаНаЛист()
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
JobSheet sh
Next
End Sub
Sub JobSheet(sh As Worksheet)
With sh
Dim yy As Long
yy = .Cells(.Rows.Count, 1).End(xlUp).Row
If yy >
4 Then
.Range(.Cells(5, 3), .Cells(yy, 4)).Value
= Array(.Range("B3").Value, .Name)
.Rows("1:4").Delete Shift:=xlUp
End If
End With
End Sub
Здравствуйте, прошу подсказать в ситуации, есть таблицы с исходными данными, но она сформирована в сплошном формате (где категории и их элементы отображены в одном столбце), прошу подсказать макрос, который может перенести название категорий в отдельный столбец и протянуть до названия следующей категории?(пример прикреплен), элементов внутри каждой категории 94, мб поможет (1 строка название категории, последующие 94 элементы ее, затем 96 строка - название категории И так далее)Спасибо большое!
Sub example1()
Dim inpdata As Range, realdata As Range, ns As Worksheet
Dim i&, j&, k&, c&, r&, hc&, hr&
Dim out() As String, dataArr, hcArr, hrArr
Dim x As Worksheet
Set inpdata = ThisWorkbook.Application.InputBox( _
prompt:="Выберите обрабатываемый диапазон:", Title:="Выбор диапазона", Type:=8)
hr = Val(InputBox("Сколько строк с подписями сверху?"))
hc = Val(InputBox("Сколько столбцов с подписями слева?"))
For Each x In ThisWorkbook.Worksheets()
If inpdata.Rows.Count <= hr Or inpdata.Columns.Count <= hc Then Exit Sub
Set realdata = inpdata.Offset(hr, hc).Resize(inpdata.Rows.Count - hr, inpdata.Columns.Count - hc)
dataArr = realdata.Value
If hr Then hrArr = inpdata.Offset(0, hc).Resize(hr, inpdata.Columns.Count - hc).Value
If hc Then hcArr = inpdata.Offset(hr, 0).Resize(inpdata.Rows.Count - hr, hc).Value
ReDim out(1 To Application.CountA(realdata), 1 To hr + hc + 1)
Set ns = Worksheets.Add
For i = 1 To UBound(dataArr, 1)
For j = 1 To UBound(dataArr, 2)
If Not IsEmpty(dataArr(i, j)) Then
k = k + 1
For c = 1 To hc: out(k, c) = hcArr(i, c): Next c
For r = 1 To hr: out(k, c + r - 1) = hrArr(r, j): Next r
out(k, c + r - 1) = dataArr(i, j)
End If
Next j, i
ns.Cells(2, 1).Resize(UBound(out, 1), UBound(out, 2)) = out
Next x
End Sub
Подправил макрос, но он не хочет на все листы использоваться, выдает ошибку, в чем ошибка в коде?
sokol92, Удалил. Жалко, что для простых. Прост от макроса нужно, чтоб отработал на 1 листе под требуемые условия (которые задаются: размер таблицы, строки и столбцы), и по данным условиям дальше отработал по остальным листам
Msi2102, на каждой листе форма данных одинаковая, по идее должно быть так: на 1 листе использовать макрос - выбрать диапазон данных, затем строки и столбцы соответственно, макрос отработал редизайн листа и затем чтобы данный редизайн (условиям по макросу) были применены на следующие листы Без. сливания в один лист.
написал: я запустил ваш макрос из файла на листе "Было", выбрал весь диапазон таблицы мышкой и два раза указал цифру 1 - создался лист и он заполнился данными. Макрос отработал без ошибок. Мне сейчас не понятно, где у вас происходит ошибка. Макрос работает
макрос на 1 листе работает, я знаю. но я хотел бы, чтобы он отработал так на всех листах от одного запуска макроса.
Здравствуйте! Есть файл с небольшим количеством листов (10 примерно), у меня есть макрос, только выдает ошибку при запуске.В чем суть макроса, требуется произвести редизайна на всех листах файлах (условия редизайна одинаковы для всех листов). Условия задаются уже в макросе (выбрать область (область, количество строк сверху, столбцов слева). В чем ошибка? Буду благодарен, если так же подскажите как дописать, чтобы область он определял по кол-ву заполненный полей 1 строки и 1 столбца.
Код
Sub Redesigner()
Dim inpdata As Range, realdata As Range, ns As Worksheet
Dim i&, j&, k&, c&, r&, hc&, hr&
Dim out() As String, dataArr, hcArr, hrArr
For Each ws In Worksheets
With ws
Set inpdata = ThisWorkbook.Application.InputBox( _
prompt:="¬ыберите обрабатываемый диапазон:", Title:="¬ыбор диапазона", Type:=8)
hr = Val(InputBox("—колько строк с подпис€ми сверху?"))
hc = Val(InputBox("—колько столбцов с подпис€ми слева?"))
If inpdata.Rows.Count <= hr Or inpdata.Columns.Count <= hc Then Exit Sub
Set realdata = inpdata.Offset(hr, hc).Resize(inpdata.Rows.Count - hr, inpdata.Columns.Count - hc)
dataArr = realdata.Value
If hr Then hrArr = inpdata.Offset(0, hc).Resize(hr, inpdata.Columns.Count - hc).Value
If hc Then hcArr = inpdata.Offset(hr, 0).Resize(inpdata.Rows.Count - hr, hc).Value
ReDim out(1 To Application.CountA(realdata), 1 To hr + hc + 1)
Set ns = Worksheets.Add
For i = 1 To UBound(dataArr, 1)
For j = 1 To UBound(dataArr, 2)
If Not IsEmpty(dataArr(i, j)) Then
k = k + 1
For c = 1 To hc: out(k, c) = hcArr(i, c): Next c
For r = 1 To hr: out(k, c + r - 1) = hrArr(r, j): Next r
out(k, c + r - 1) = dataArr(i, j)
End If
Next j, i
ns.Cells(2, 1).Resize(UBound(out, 1), UBound(out, 2)) = out
End with ws
Next ws
End Sub
написал: Код ? 12345678910111213141516'можно добавить цикл пробега по всем листам 'минимально изменяя ваш макрос можно как-то так:For each ws in activebook.worksheetsws.activateWith ActiveSheet Set Rng = .Columns(3).Find(FindWord, , xlFormulas, xlWhole) 'xlWhole -ячейка целиком (xlPart - часть ячейки) If Rng Is Nothing Then MsgBox "Слово '" & FindWord & "' не найдено в 3-м столбце!", vbExclamation, "Внимание" Exit Sub End If firstAddres = Rng.Address Do .Rows(Rng.Row).Copy .Rows(Rng.Row + 1).Insert Shift:=xlDown .Cells(Rng.Row + 1, 3) = ReplaceWord Set Rng = .Columns(3).FindNext(Rng) Loop Until Rng.Address = firstAddres End With Next
Кому решение нужно - тот пример и рисует.
Я попытался сделать что то похожее с другим запросом, но тут ошибка. В чем я ошибся? Выше исписанный запрос, не подошел под требования, которые мне надо в таблице сделать.
написал: Насколько я знаю, "на всех листах сразу" - так нельзя. Это примерно как ехать на автомобиле одновременно на работу, в отпуск к морю, в магазин за новым креслом и на рынок за мангалом.Сначала одно, потом другое. Сначала один объект (лист), потом другой.Насколько я знаю.
Это да, пусть последовательно. Просто сам факт, чтобы макрос проделывал все, не приходилось в ручную каждый лист запускать макрос.
написал: и что ваш макрос должен делать? не считая прохода по листам.Ваш только проверяет имя листа и ничего не делает.П.С. Имя листа не может быть пустыОбщ
Общая идея, чтобы макрос выполнялся на всех листа сразу, а не проходить по каждому из них. Вот хотел модернизировать.
Здравствуйте, не поможете, есть макрос для редизайна таблицы, но в Ексель около 10-15 листов, не получается написать макрос, чтоб мой макрос выполнялся на всех листах. Буду благодарен за помощь. (макрос, который я пытался сделать для выполнения на всех листах)
Код
for I=1 to sheets.count
if worksheets(i).name<> ""then
end if
next I
Здравствуйте! прошу подсказать, как дописать макрос, чтобы после использования его не менялся формат ячеек? То после использование ячейки меняют формат либо знаки в самой ячейке, к примеру, изначально была ячейка "12.2" после использования макроса формат ячейки стал "12,2" либо "12 янв." Прикрепляю код и пример:
Код
Sub Redesigner()
Dim inpdata As Range, realdata As Range, ns As Worksheet
Dim i&, j&, k&, c&, r&, hc&, hr&
Dim out(), dataArr, hcArr, hrArr
Set inpdata = ThisWorkbook.Application.InputBox( _ prompt:="Выберите обрабатываемый диапазон:", Title:="Выбор диапазона", Type:=8)
hr = Val(InputBox("Сколько строк с подписями сверху?"))
hc = Val(InputBox("Сколько столбцов с подписями слева?"))
If inpdata.Rows.Count <= hr Or inpdata.Columns.Count <= hc Then Exit Sub
Set realdata = inpdata.Offset(hr, hc).Resize(inpdata.Rows.Count - hr, inpdata.Columns.Count - hc)
dataArr = realdata.Value If hr Then hrArr = inpdata.Offset(0, hc).Resize(hr, inpdata.Columns.Count - hc).Value
If hc Then hcArr = inpdata.Offset(hr, 0).Resize(inpdata.Rows.Count - hr, hc).Value
ReDim out(1 To Application.CountA(realdata), 1 To hr + hc + 1)
Set ns = Worksheets.Add
For i = 1 To UBound(dataArr, 1)
For j = 1 To UBound(dataArr, 2)
If Not IsEmpty(dataArr(i, j)) Then
k = k + 1
For c = 1 To hc: out(k, c) = hcArr(i, c): Next c
For r = 1 To hr: out(k, c + r - 1) = hrArr(r, j): Next r
out(k, c + r - 1) = dataArr(i, j)
End If Next j, I
ns.Cells(2, 1).Resize(UBound(out, 1),
UBound(out, 2)) = out
End Sub
написал: Sub Дублирование_строки() Dim FindWord As String, ReplaceWord As String, Rng As Range, firstAddres As String FindWord = Application.InputBox("Какое слово найти в 3-м столбце?", "Поиск слова") If FindWord = Empty Then Exit Sub ReplaceWord = Application.InputBox("На какое слово заменить?", "Поиск слова") If ReplaceWord = Empty Then Exit Sub With ActiveSheet Set Rng = .Columns(3).Find(FindWord, , xlFormulas, xlWhole) 'xlWhole -ячейка целиком (xlPart - часть ячейки) If Rng Is Nothing Then MsgBox "Слово '" & FindWord & "' не найдено в 3-м столбце!", vbExclamation, "Внимание" Exit Sub End If firstAddres = Rng.Address Do .Rows(Rng.Row).Copy .Rows(Rng.Row + 1).Insert Shift:=xlDown .Cells(Rng.Row + 1, 3) = ReplaceWord Set Rng = .Columns(3).FindNext(Rng) Loop Until Rng.Address = firstAddres End With MsgBox "Сделано!", vbInformation, "Конец"End Sub
Здравствуйте! Прошу подсказать, как можно решить такой вопрос. Подскажите с макросом, который будет делать следующие шаги:-Находит нужную строку (строки) в массиве данных по определённому слову - Дублирует данную строку полностью (строки) - Переименовывает слово (по которому был сделан поиск) на требуемое (задается пользователем) На примере прикрепляю файл: Таблица с "было" и "стало", где был сделан поиск по слову "1 кв", далее строки были продублированы и переименованы на "1 кв.н". Спасибо большое за помощь заранее!
Смещение строк в столбец (как продолжение строки) под динамическое количество строк, Макрос для смещение строк в столбец, чтоб была группировки от названия столбца
написал: протяните вправо на одну ячейку и вниз до конца таблицыустановите фильтр и отсортируйте по столбцу С (Прибыль) пустые ячейкиМожете скопировать полученные два столбца и вставить только значения, после чего тот же фильтр, только выделить только пустые ячейки и удалить эти строки.