Здравствуйте, есть вопрос: есть документ с которым я работаю. Сейчас хочу дописать макрос так, чтобы он по выбранному порядку в доп таблице(выделена желтым) формировал документ, не знаю как нормально описать, файл прикрепил. Там 2 листа 1) Перечень, в нем работаем, выбираем порядок в табличке и жмем на кнопку, во 2 листе конечный результат который хотелось бы видеть.
Здравствуйте, есть вопрос: есть документ с которым я работаю. Сейчас хочу дописать макрос так, чтобы он по выбранному порядку в доп таблице(выделена желтым) формировал документ, не знаю как нормально описать, файл прикрепил. Там 2 листа 1) Перечень, в нем работаем, выбираем порядок в табличке и жмем на кнопку, во 2 листе конечный результат который хотелось бы видеть.albertikhsanov00
Sub Перенос() Dim n As Integer, m As Integer, k As Integer, arr1, arr2, arr3, y, lit As String Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set dic = CreateObject("Scripting.Dictionary") arr1 = Worksheets("Перечень").Range("L2:O" & Worksheets("Перечень").Cells(Rows.Count, 12).End(xlUp).Row) arr2 = Worksheets("Перечень").Range("A7:J" & Worksheets("Перечень").Cells(Rows.Count, 1).End(xlUp).Row) For Each y In Array("A", "B", "C", "D", "E", "F") dic.Add y, y Next For n = 1 To UBound(arr2) If dic.exists(arr2(n, 2)) Then Set dic(arr2(n, 2)) = CreateObject("Scripting.Dictionary") lit = arr2(n, 2) m = 0 End If m = m + 1 dic(lit).Add m, Application.WorksheetFunction.Trim(arr2(n, 1) & "|" & arr2(n, 2) & "|" & arr2(n, 3) & " " & arr2(n, 4) & " " & arr2(n, 5) & " " & arr2(n, 6) & " " & arr2(n, 7) & "|" & arr2(n, 8) & "|" & arr2(n, 9) & "|" & arr2(n, 10)) Next k = 5 For m = 1 To UBound(arr1) For n = 1 To UBound(arr1, 2) If n = 1 Then Worksheets("Обработка").Cells(k, 1) = arr1(m, n) Worksheets("Обработка").Cells(k, 1).Resize(1, 6).Interior.Color = 16751001 k = k + 1 Else If arr1(m, n) <> "" Then If dic.exists(arr1(m, n)) Then For Each y In dic(arr1(m, n)) arr3 = Split(dic(arr1(m, n)).Item(y), "|") If arr3(1) = arr1(m, n) Then Worksheets("Обработка").Cells(k, 1).Resize(1, 6).Interior.Color = 16764108 Worksheets("Обработка").Cells(k, 1).Resize(1, 6).Value = arr3 Worksheets("Обработка").Cells(k, 1).Resize(1, 6).Value = Worksheets("Обработка").Cells(k, 1).Resize(1, 6).Value k = k + 1 Next End If End If End If Next Next Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True MsgBox "Перенос данных выполнен" End Sub
[/vba] Обратите внимание, что у Вас в столбце "Количество" имеются значения, но их не видно, потому что цвет заливки совпадает с цветом шрифта Ячейки с наименованием объединил в одну, как в примере, только вставляется в один столбец, если нужно в пять столбцов, как в примере отпишитесь, исправлю. С форматированием особо не заморачивался, добавите сами
Попробуйте так [vba]
Код
Sub Перенос() Dim n As Integer, m As Integer, k As Integer, arr1, arr2, arr3, y, lit As String Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set dic = CreateObject("Scripting.Dictionary") arr1 = Worksheets("Перечень").Range("L2:O" & Worksheets("Перечень").Cells(Rows.Count, 12).End(xlUp).Row) arr2 = Worksheets("Перечень").Range("A7:J" & Worksheets("Перечень").Cells(Rows.Count, 1).End(xlUp).Row) For Each y In Array("A", "B", "C", "D", "E", "F") dic.Add y, y Next For n = 1 To UBound(arr2) If dic.exists(arr2(n, 2)) Then Set dic(arr2(n, 2)) = CreateObject("Scripting.Dictionary") lit = arr2(n, 2) m = 0 End If m = m + 1 dic(lit).Add m, Application.WorksheetFunction.Trim(arr2(n, 1) & "|" & arr2(n, 2) & "|" & arr2(n, 3) & " " & arr2(n, 4) & " " & arr2(n, 5) & " " & arr2(n, 6) & " " & arr2(n, 7) & "|" & arr2(n, 8) & "|" & arr2(n, 9) & "|" & arr2(n, 10)) Next k = 5 For m = 1 To UBound(arr1) For n = 1 To UBound(arr1, 2) If n = 1 Then Worksheets("Обработка").Cells(k, 1) = arr1(m, n) Worksheets("Обработка").Cells(k, 1).Resize(1, 6).Interior.Color = 16751001 k = k + 1 Else If arr1(m, n) <> "" Then If dic.exists(arr1(m, n)) Then For Each y In dic(arr1(m, n)) arr3 = Split(dic(arr1(m, n)).Item(y), "|") If arr3(1) = arr1(m, n) Then Worksheets("Обработка").Cells(k, 1).Resize(1, 6).Interior.Color = 16764108 Worksheets("Обработка").Cells(k, 1).Resize(1, 6).Value = arr3 Worksheets("Обработка").Cells(k, 1).Resize(1, 6).Value = Worksheets("Обработка").Cells(k, 1).Resize(1, 6).Value k = k + 1 Next End If End If End If Next Next Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True MsgBox "Перенос данных выполнен" End Sub
[/vba] Обратите внимание, что у Вас в столбце "Количество" имеются значения, но их не видно, потому что цвет заливки совпадает с цветом шрифта Ячейки с наименованием объединил в одну, как в примере, только вставляется в один столбец, если нужно в пять столбцов, как в примере отпишитесь, исправлю. С форматированием особо не заморачивался, добавите самиmsi2102
msi2102, пытался ваш код прописать в свой ничего не вышло. У вас он переносит строки и объединяет наименование, а у меня он копирует перечень в новую книгу и работает с ним, можно его как-нибудь добавить в мой?
msi2102, пытался ваш код прописать в свой ничего не вышло. У вас он переносит строки и объединяет наименование, а у меня он копирует перечень в новую книгу и работает с ним, можно его как-нибудь добавить в мой?albertikhsanov00
Не совсем понимаю, что именно Вы хотите, если нужно перенести в новую книгу, то сделайте так. Разбираться с Вашими макросами нет особого желания. [vba]
Код
Sub Перенос() Dim n As Integer, m As Integer, k As Integer, arr1, arr2, arr3, arr4, y, lit As String Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set dic = CreateObject("Scripting.Dictionary") arr1 = Worksheets("Перечень").Range("L2:O" & Worksheets("Перечень").Cells(Rows.Count, 12).End(xlUp).Row) arr2 = Worksheets("Перечень").Range("A7:J" & Worksheets("Перечень").Cells(Rows.Count, 1).End(xlUp).Row) For Each y In Array("A", "B", "C", "D", "E", "F") dic.Add y, y Next arr4 = Array("№ п/п", "Поз. на тех. схеме", "Наименование", "Ед.изм", "Кол-во", "Назначение/примечание") For n = 1 To UBound(arr2) If dic.exists(arr2(n, 2)) Then Set dic(arr2(n, 2)) = CreateObject("Scripting.Dictionary") lit = arr2(n, 2) m = 0 End If m = m + 1 dic(lit).Add m, Application.WorksheetFunction.Trim(arr2(n, 1) & "|" & arr2(n, 2) & "|" & arr2(n, 3) & " " & arr2(n, 4) & " " & arr2(n, 5) & " " & arr2(n, 6) & " " & arr2(n, 7) & "|" & arr2(n, 8) & "|" & arr2(n, 9) & "|" & arr2(n, 10)) Next Workbooks.Add With ActiveWorkbook.ActiveSheet .Cells.VerticalAlignment = xlTop .Columns("B:B").ColumnWidth = 12 .Columns("B:B").NumberFormat = "@" .Columns("C:C").ColumnWidth = 75 .Columns("F:F").ColumnWidth = 50 .Range("A4:F4") = arr4 .Range("A4:F4").Interior.Color = 16764108 .Range("A4:F4").Font.Bold = True .Range("A4:F4").HorizontalAlignment = xlCenter .Range("A4:F4").WrapText = True k = 5 For m = 1 To UBound(arr1) For n = 1 To UBound(arr1, 2) If n = 1 Then .Cells(k, 1) = arr1(m, n) .Cells(k, 1).Resize(1, 6).Interior.Color = 16751001 k = k + 1 Else If arr1(m, n) <> "" Then If dic.exists(arr1(m, n)) Then For Each y In dic(arr1(m, n)) arr3 = Split(dic(arr1(m, n)).Item(y), "|") If arr3(1) = arr1(m, n) Then .Cells(k, 1).Resize(1, 6).Interior.Color = 16764108 .Cells(k, 1).Resize(1, 6).Value = arr3 .Cells(k, 1).Resize(1, 6).Value = .Cells(k, 1).Resize(1, 6).Value k = k + 1 Next End If End If End If Next Next .Range("A4:F" & k - 1).Borders.LineStyle = xlContinuous End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True MsgBox "Перенос данных выполнен" End Sub
Не совсем понимаю, что именно Вы хотите, если нужно перенести в новую книгу, то сделайте так. Разбираться с Вашими макросами нет особого желания. [vba]
Код
Sub Перенос() Dim n As Integer, m As Integer, k As Integer, arr1, arr2, arr3, arr4, y, lit As String Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set dic = CreateObject("Scripting.Dictionary") arr1 = Worksheets("Перечень").Range("L2:O" & Worksheets("Перечень").Cells(Rows.Count, 12).End(xlUp).Row) arr2 = Worksheets("Перечень").Range("A7:J" & Worksheets("Перечень").Cells(Rows.Count, 1).End(xlUp).Row) For Each y In Array("A", "B", "C", "D", "E", "F") dic.Add y, y Next arr4 = Array("№ п/п", "Поз. на тех. схеме", "Наименование", "Ед.изм", "Кол-во", "Назначение/примечание") For n = 1 To UBound(arr2) If dic.exists(arr2(n, 2)) Then Set dic(arr2(n, 2)) = CreateObject("Scripting.Dictionary") lit = arr2(n, 2) m = 0 End If m = m + 1 dic(lit).Add m, Application.WorksheetFunction.Trim(arr2(n, 1) & "|" & arr2(n, 2) & "|" & arr2(n, 3) & " " & arr2(n, 4) & " " & arr2(n, 5) & " " & arr2(n, 6) & " " & arr2(n, 7) & "|" & arr2(n, 8) & "|" & arr2(n, 9) & "|" & arr2(n, 10)) Next Workbooks.Add With ActiveWorkbook.ActiveSheet .Cells.VerticalAlignment = xlTop .Columns("B:B").ColumnWidth = 12 .Columns("B:B").NumberFormat = "@" .Columns("C:C").ColumnWidth = 75 .Columns("F:F").ColumnWidth = 50 .Range("A4:F4") = arr4 .Range("A4:F4").Interior.Color = 16764108 .Range("A4:F4").Font.Bold = True .Range("A4:F4").HorizontalAlignment = xlCenter .Range("A4:F4").WrapText = True k = 5 For m = 1 To UBound(arr1) For n = 1 To UBound(arr1, 2) If n = 1 Then .Cells(k, 1) = arr1(m, n) .Cells(k, 1).Resize(1, 6).Interior.Color = 16751001 k = k + 1 Else If arr1(m, n) <> "" Then If dic.exists(arr1(m, n)) Then For Each y In dic(arr1(m, n)) arr3 = Split(dic(arr1(m, n)).Item(y), "|") If arr3(1) = arr1(m, n) Then .Cells(k, 1).Resize(1, 6).Interior.Color = 16764108 .Cells(k, 1).Resize(1, 6).Value = arr3 .Cells(k, 1).Resize(1, 6).Value = .Cells(k, 1).Resize(1, 6).Value k = k + 1 Next End If End If End If Next Next .Range("A4:F" & k - 1).Borders.LineStyle = xlContinuous End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True MsgBox "Перенос данных выполнен" End Sub
Sub Перенос() Dim n As Integer, m As Integer, k As Integer, arr1, arr2, arr3, arr4, y, lit As String, rng As Range Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set dic = CreateObject("Scripting.Dictionary") arr1 = Worksheets("Перечень").Range("L2:O" & Worksheets("Перечень").Cells(Rows.Count, 12).End(xlUp).Row) arr2 = Worksheets("Перечень").Range("A7:J" & Worksheets("Перечень").Cells(Rows.Count, 1).End(xlUp).Row) For Each y In Array("A", "B", "C", "D", "E", "F") dic.Add y, y Next arr4 = Array("№ п/п", "Поз. на тех. схеме", "Наименование", "Ед.изм", "Кол-во", "Назначение/примечание") For n = 1 To UBound(arr2) If dic.exists(arr2(n, 2)) Then Set dic(arr2(n, 2)) = CreateObject("Scripting.Dictionary") lit = arr2(n, 2) m = 0 End If m = m + 1 dic(lit).Add m, Application.WorksheetFunction.Trim(arr2(n, 1) & "|" & arr2(n, 2) & "|" & arr2(n, 3) & " " & arr2(n, 4) & " " & arr2(n, 5) & " " & arr2(n, 6) & " " & arr2(n, 7) & "|" & arr2(n, 8) & "|" & arr2(n, 9) & "|" & arr2(n, 10)) Next Workbooks.Add With ActiveWorkbook.ActiveSheet .Cells.VerticalAlignment = xlTop .Columns("B:B").ColumnWidth = 12 .Columns("B:B").NumberFormat = "@" .Columns("C:C").ColumnWidth = 75 .Columns("F:F").ColumnWidth = 50 .Range("A4:F4") = arr4 .Range("A4:F4").Interior.Color = 16764108 .Range("A4:F4").Font.Bold = True .Range("A4:F4").HorizontalAlignment = xlCenter .Range("A4:F4").WrapText = True k = 5 Set rng = .Range("A4:F4") For m = 1 To UBound(arr1) For n = 1 To UBound(arr1, 2) If n = 1 Then .Cells(k, 1) = arr1(m, n) .Cells(k, 1).Resize(1, 6).Interior.Color = 16751001 Set rng = Union(rng, .Cells(k, 1).Resize(1, 6)) k = k + 1 Else If arr1(m, n) <> "" Then If dic.exists(arr1(m, n)) Then For Each y In dic(arr1(m, n)) arr3 = Split(dic(arr1(m, n)).Item(y), "|") If arr3(1) = arr1(m, n) Then .Cells(k, 1).Resize(1, 6).Interior.Color = 16764108: Set rng = Union(rng, .Cells(k, 1).Resize(1, 6)) .Cells(k, 1).Resize(1, 6).Value = arr3 .Cells(k, 1).Resize(1, 6).Value = .Cells(k, 1).Resize(1, 6).Value k = k + 1 Next End If End If End If Next Next .Range("A4:F" & k - 1).Borders.LineStyle = xlContinuous .Range("A4:F" & k - 1).BorderAround ColorIndex:=0, Weight:=xlMedium With rng .Borders(xlEdgeLeft).LineStyle = xlContinuous .Borders(xlEdgeLeft).Weight = xlMedium .Borders(xlEdgeTop).LineStyle = xlContinuous .Borders(xlEdgeTop).Weight = xlMedium .Borders(xlEdgeBottom).LineStyle = xlContinuous .Borders(xlEdgeBottom).Weight = xlMedium .Borders(xlEdgeRight).LineStyle = xlContinuous .Borders(xlEdgeRight).Weight = xlMedium .Borders(xlInsideVertical).LineStyle = xlContinuous .Borders(xlInsideVertical).Weight = xlThin .Borders(xlInsideHorizontal).LineStyle = xlContinuous .Borders(xlInsideHorizontal).Weight = xlMedium End With End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True MsgBox "Перенос данных выполнен" End Sub
[/vba]
Дописал Вам форматирование [vba]
Код
Sub Перенос() Dim n As Integer, m As Integer, k As Integer, arr1, arr2, arr3, arr4, y, lit As String, rng As Range Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set dic = CreateObject("Scripting.Dictionary") arr1 = Worksheets("Перечень").Range("L2:O" & Worksheets("Перечень").Cells(Rows.Count, 12).End(xlUp).Row) arr2 = Worksheets("Перечень").Range("A7:J" & Worksheets("Перечень").Cells(Rows.Count, 1).End(xlUp).Row) For Each y In Array("A", "B", "C", "D", "E", "F") dic.Add y, y Next arr4 = Array("№ п/п", "Поз. на тех. схеме", "Наименование", "Ед.изм", "Кол-во", "Назначение/примечание") For n = 1 To UBound(arr2) If dic.exists(arr2(n, 2)) Then Set dic(arr2(n, 2)) = CreateObject("Scripting.Dictionary") lit = arr2(n, 2) m = 0 End If m = m + 1 dic(lit).Add m, Application.WorksheetFunction.Trim(arr2(n, 1) & "|" & arr2(n, 2) & "|" & arr2(n, 3) & " " & arr2(n, 4) & " " & arr2(n, 5) & " " & arr2(n, 6) & " " & arr2(n, 7) & "|" & arr2(n, 8) & "|" & arr2(n, 9) & "|" & arr2(n, 10)) Next Workbooks.Add With ActiveWorkbook.ActiveSheet .Cells.VerticalAlignment = xlTop .Columns("B:B").ColumnWidth = 12 .Columns("B:B").NumberFormat = "@" .Columns("C:C").ColumnWidth = 75 .Columns("F:F").ColumnWidth = 50 .Range("A4:F4") = arr4 .Range("A4:F4").Interior.Color = 16764108 .Range("A4:F4").Font.Bold = True .Range("A4:F4").HorizontalAlignment = xlCenter .Range("A4:F4").WrapText = True k = 5 Set rng = .Range("A4:F4") For m = 1 To UBound(arr1) For n = 1 To UBound(arr1, 2) If n = 1 Then .Cells(k, 1) = arr1(m, n) .Cells(k, 1).Resize(1, 6).Interior.Color = 16751001 Set rng = Union(rng, .Cells(k, 1).Resize(1, 6)) k = k + 1 Else If arr1(m, n) <> "" Then If dic.exists(arr1(m, n)) Then For Each y In dic(arr1(m, n)) arr3 = Split(dic(arr1(m, n)).Item(y), "|") If arr3(1) = arr1(m, n) Then .Cells(k, 1).Resize(1, 6).Interior.Color = 16764108: Set rng = Union(rng, .Cells(k, 1).Resize(1, 6)) .Cells(k, 1).Resize(1, 6).Value = arr3 .Cells(k, 1).Resize(1, 6).Value = .Cells(k, 1).Resize(1, 6).Value k = k + 1 Next End If End If End If Next Next .Range("A4:F" & k - 1).Borders.LineStyle = xlContinuous .Range("A4:F" & k - 1).BorderAround ColorIndex:=0, Weight:=xlMedium With rng .Borders(xlEdgeLeft).LineStyle = xlContinuous .Borders(xlEdgeLeft).Weight = xlMedium .Borders(xlEdgeTop).LineStyle = xlContinuous .Borders(xlEdgeTop).Weight = xlMedium .Borders(xlEdgeBottom).LineStyle = xlContinuous .Borders(xlEdgeBottom).Weight = xlMedium .Borders(xlEdgeRight).LineStyle = xlContinuous .Borders(xlEdgeRight).Weight = xlMedium .Borders(xlInsideVertical).LineStyle = xlContinuous .Borders(xlInsideVertical).Weight = xlThin .Borders(xlInsideHorizontal).LineStyle = xlContinuous .Borders(xlInsideHorizontal).Weight = xlMedium End With End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True MsgBox "Перенос данных выполнен" End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
