Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Распределение строк по условию - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Распределение строк по условию (Макросы/Sub)
Распределение строк по условию
albertikhsanov00 Дата: Пятница, 20.01.2023, 11:57 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 24
Репутация: 0 ±
Замечаний: 20% ±

Здравствуйте, есть вопрос: есть документ с которым я работаю. Сейчас хочу дописать макрос так, чтобы он по выбранному порядку в доп таблице(выделена желтым) формировал документ, не знаю как нормально описать, файл прикрепил. Там 2 листа 1) Перечень, в нем работаем, выбираем порядок в табличке и жмем на кнопку, во 2 листе конечный результат который хотелось бы видеть.
К сообщению приложен файл: 2855226.xlsm(275.8 Kb)
 
Ответить
СообщениеЗдравствуйте, есть вопрос: есть документ с которым я работаю. Сейчас хочу дописать макрос так, чтобы он по выбранному порядку в доп таблице(выделена желтым) формировал документ, не знаю как нормально описать, файл прикрепил. Там 2 листа 1) Перечень, в нем работаем, выбираем порядок в табличке и жмем на кнопку, во 2 листе конечный результат который хотелось бы видеть.

Автор - albertikhsanov00
Дата добавления - 20.01.2023 в 11:57
msi2102 Дата: Суббота, 21.01.2023, 23:02 | Сообщение № 2
Группа: Проверенные
Ранг: Обитатель
Сообщений: 263
Репутация: 94 ±
Замечаний: 0% ±

Excel 2007
Попробуйте так
[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]
Обратите внимание, что у Вас в столбце "Количество" имеются значения, но их не видно, потому что цвет заливки совпадает с цветом шрифта
Ячейки с наименованием объединил в одну, как в примере, только вставляется в один столбец, если нужно в пять столбцов, как в примере отпишитесь, исправлю.
С форматированием особо не заморачивался, добавите сами
К сообщению приложен файл: 2855226_1.xlsm(87.5 Kb)


Сообщение отредактировал msi2102 - Суббота, 21.01.2023, 23:32
 
Ответить
СообщениеПопробуйте так
[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
Дата добавления - 21.01.2023 в 23:02
albertikhsanov00 Дата: Понедельник, 23.01.2023, 08:49 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 24
Репутация: 0 ±
Замечаний: 20% ±

msi2102, пытался ваш код прописать в свой ничего не вышло. У вас он переносит строки и объединяет наименование, а у меня он копирует перечень в новую книгу и работает с ним, можно его как-нибудь добавить в мой?
 
Ответить
Сообщениеmsi2102, пытался ваш код прописать в свой ничего не вышло. У вас он переносит строки и объединяет наименование, а у меня он копирует перечень в новую книгу и работает с ним, можно его как-нибудь добавить в мой?

Автор - albertikhsanov00
Дата добавления - 23.01.2023 в 08:49
msi2102 Дата: Понедельник, 23.01.2023, 11:57 | Сообщение № 4
Группа: Проверенные
Ранг: Обитатель
Сообщений: 263
Репутация: 94 ±
Замечаний: 0% ±

Excel 2007
Цитата albertikhsanov00, 23.01.2023 в 08:49, в сообщении № 3 ()
можно его как-нибудь добавить в мой
Не совсем понимаю, что именно Вы хотите, если нужно перенести в новую книгу, то сделайте так. Разбираться с Вашими макросами нет особого желания.
[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]
PS: нужное форматирование допишите сами
К сообщению приложен файл: 2855226_1-1-.xlsm(88.6 Kb)
 
Ответить
Сообщение
Цитата albertikhsanov00, 23.01.2023 в 08:49, в сообщении № 3 ()
можно его как-нибудь добавить в мой
Не совсем понимаю, что именно Вы хотите, если нужно перенести в новую книгу, то сделайте так. Разбираться с Вашими макросами нет особого желания.
[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]
PS: нужное форматирование допишите сами

Автор - msi2102
Дата добавления - 23.01.2023 в 11:57
albertikhsanov00 Дата: Вторник, 24.01.2023, 09:56 | Сообщение № 5
Группа: Пользователи
Ранг: Новичок
Сообщений: 24
Репутация: 0 ±
Замечаний: 20% ±

msi2102, спасибо за помощь, дальше как-нибудь разберусь
 
Ответить
Сообщениеmsi2102, спасибо за помощь, дальше как-нибудь разберусь

Автор - albertikhsanov00
Дата добавления - 24.01.2023 в 09:56
msi2102 Дата: Вторник, 24.01.2023, 12:24 | Сообщение № 6
Группа: Проверенные
Ранг: Обитатель
Сообщений: 263
Репутация: 94 ±
Замечаний: 0% ±

Excel 2007
Дописал Вам форматирование
[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
[/vba]
К сообщению приложен файл: 5938224.xlsm(89.6 Kb)
 
Ответить
СообщениеДописал Вам форматирование
[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
[/vba]

Автор - msi2102
Дата добавления - 24.01.2023 в 12:24
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Распределение строк по условию (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2023 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!