Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Перенос Формата ячеек на другой лист
 
#1
19.08.2019 13:41:37
Добрый день, во вложении пример с макросом "Макрос_для_символ10", который формирует новый лист, при этом разделяя ячейки с символом10 на самостоятельные строки.
Как мне в этом макросе осуществить перенос форматирования (цвет ячейки, шрифт) на мой новый лист?
 
 
 
#2
19.08.2019 23:36:14
AT-FIT, здравствуйте.
Можно было просто макрорекордером записать специальную вставку…
Изменено: Jack Famous - 19.08.2019 23:48:35
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
#3
20.08.2019 02:40:29
Цитата
xxddsxx написал:
перенос форматирования (цвет ячейки, шрифт)
Может например так ?
Код
Option Explicit

Sub abc_xyz()
    Dim i As Long
    Dim ptrn As Object, cell As Object
    
    Set ptrn = Sheets("Rezerv").Range("A1:B22")
    
    For Each cell In Sheets("Rezerv").Range("D1:E22").Cells
        i = i + 1
        With ptrn.Cells(i)
            'cell.Value = .Value
            cell.Interior.Color = .Interior.Color
            cell.Font.Name = .Font.Name
            cell.Font.Size = .Font.Size
            cell.Font.FontStyle = .Font.FontStyle
            cell.Font.Color = .Font.Color
            cell.HorizontalAlignment = .HorizontalAlignment
            cell.VerticalAlignment = .VerticalAlignment
            'i t.d.
        End With
    Next
    
    Set ptrn = Nothing
End Sub
 
 
 
#4
20.08.2019 10:53:30
Всем спасибо, сделал так:
Код
Sub Ìàêñðîñ_äëÿ_Ñèìâîë10()

    Dim rng_all_data As Range
    Set rng_all_data = Application.InputBox("Âûäåëèòå äèàïàçîí:", Selection.Address, Type:=8)
    
    Dim int_row As Integer
    int_row = 0


    Dim sheet_out As Worksheet
    Set sheet_out = Worksheets.Add

    Dim rng_row As Range
    For Each rng_row In rng_all_data.Rows

        Dim int_column As Integer
        int_column = 0

        Dim int_max_splits As Integer
        int_max_splits = 0

        Dim rng_column As Range
        For Each rng_column In rng_row.Columns
  rng_column.Copy
 
            Dim column_parts As Variant
            column_parts = Split(rng_column, vbLf)
            '----
            If UBound(column_parts) > int_max_splits Then
               int_max_splits = UBound(column_parts)
            End If

If UBound(column_parts) >= 1 Then

        sheet_out.Range("A1").Offset(int_row, int_column).Resize(UBound(column_parts) + 1) = Application.Transpose(column_parts)
        With sheet_out.Range("A1").Offset(int_row, int_column).Resize(UBound(column_parts) + 1)
        .PasteSpecial Paste:=xlPasteFormats
        .PasteSpecial Paste:=xlPasteColumnWidths
        .PasteSpecial Paste:=xlPasteComments
        .PasteSpecial Paste:=xlPasteValidation
        End With
        Application.CutCopyMode = False
        int_column = int_column + 1
 
        Else

        sheet_out.Range("A1").Offset(int_row, int_column) = column_parts
        With sheet_out.Range("A1").Offset(int_row, int_column)
        .PasteSpecial Paste:=xlPasteFormats
        .PasteSpecial Paste:=xlPasteColumnWidths
        .PasteSpecial Paste:=xlPasteComments
        .PasteSpecial Paste:=xlPasteValidation
        End With
        Application.CutCopyMode = False
        int_column = int_column + 1
        End If
        Next
        int_row = int_row + int_max_splits + 1
    Next


End Sub
 
 
 
#5
20.08.2019 15:57:02
AT-FIT, чтобы не было "кракозябр" типа "Ìàêñðîñ_äëÿ_Ñèìâîë10" при копировании кириллицы следите за тем, чтобы стояла русская раскладка клавиатуры
Изменено: Jack Famous - 20.08.2019 15:57:13
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
Страницы: 1
Наверх