Vba excel скопировать формат строки

Remember that when you write:

MyArray = Range("A1:A5000")

you are really writing

MyArray = Range("A1:A5000").Value

You can also use names:

MyArray = Names("MyWSTable").RefersToRange.Value

But Value is not the only property of Range. I have used:

MyArray = Range("A1:A5000").NumberFormat

I doubt

MyArray = Range("A1:A5000").Font

would work but I would expect

MyArray = Range("A1:A5000").Font.Bold

to work.

I do not know what formats you want to copy so you will have to try.

However, I must add that when you copy and paste a large range, it is not as much slower than doing it via an array as we all thought.

Post Edit information

Having posted the above I tried by own advice. My experiments with copying Font.Color and Font.Bold to an array have failed.

Of the following statements, the second would fail with a type mismatch:

  ValueArray = .Range("A1:T5000").Value
  ColourArray = .Range("A1:T5000").Font.Color

ValueArray must be of type variant. I tried both variant and long for ColourArray without success.

I filled ColourArray with values and tried the following statement:

  .Range("A1:T5000").Font.Color = ColourArray

The entire range would be coloured according to the first element of ColourArray and then Excel looped consuming about 45% of the processor time until I terminated it with the Task Manager.

There is a time penalty associated with switching between worksheets but recent questions about macro duration have caused everyone to review our belief that working via arrays was substantially quicker.

I constructed an experiment that broadly reflects your requirement. I filled worksheet Time1 with 5000 rows of 20 cells which were selectively formatted as: bold, italic, underline, subscript, bordered, red, green, blue, brown, yellow and gray-80%.

With version 1, I copied every 7th cells from worksheet «Time1» to worksheet «Time2» using copy.

With version 2, I copied every 7th cells from worksheet «Time1» to worksheet «Time2» by copying the value and the colour via an array.

With version 3, I copied every 7th cells from worksheet «Time1» to worksheet «Time2» by copying the formula and the colour via an array.

Version 1 took an average of 12.43 seconds, version 2 took an average of 1.47 seconds while version 3 took an average of 1.83 seconds. Version 1 copied formulae and all formatting, version 2 copied values and colour while version 3 copied formulae and colour. With versions 1 and 2 you could add bold and italic, say, and still have some time in hand. However, I am not sure it would be worth the bother given that copying 21,300 values only takes 12 seconds.

** Code for Version 1**

I do not think this code includes anything that needs an explanation. Respond with a comment if I am wrong and I will fix.

Sub SelectionCopyAndPaste()

  Dim ColDestCrnt As Integer
  Dim ColSrcCrnt As Integer
  Dim NumSelect As Long
  Dim RowDestCrnt As Integer
  Dim RowSrcCrnt As Integer
  Dim StartTime As Single

  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  NumSelect = 1
  ColDestCrnt = 1
  RowDestCrnt = 1
  With Sheets("Time2")
    .Range("A1:T715").EntireRow.Delete
  End With
  StartTime = Timer
  Do While True
    ColSrcCrnt = (NumSelect Mod 20) + 1
    RowSrcCrnt = (NumSelect - ColSrcCrnt) / 20 + 1
    If RowSrcCrnt > 5000 Then
      Exit Do
    End If
    Sheets("Time1").Cells(RowSrcCrnt, ColSrcCrnt).Copy _
                 Destination:=Sheets("Time2").Cells(RowDestCrnt, ColDestCrnt)
    If ColDestCrnt = 20 Then
      ColDestCrnt = 1
      RowDestCrnt = RowDestCrnt + 1
    Else
     ColDestCrnt = ColDestCrnt + 1
    End If
    NumSelect = NumSelect + 7
  Loop
  Debug.Print Timer - StartTime
  ' Average 12.43 secs
  Application.Calculation = xlCalculationAutomatic

End Sub

** Code for Versions 2 and 3**

The User type definition must be placed before any subroutine in the module. The code works through the source worksheet copying values or formulae and colours to the next element of the array. Once selection has been completed, it copies the collected information to the destination worksheet. This avoids switching between worksheets more than is essential.

Type ValueDtl
  Value As String
  Colour As Long
End Type

Sub SelectionViaArray()

  Dim ColDestCrnt As Integer
  Dim ColSrcCrnt As Integer
  Dim InxVLCrnt As Integer
  Dim InxVLCrntMax As Integer
  Dim NumSelect As Long
  Dim RowDestCrnt As Integer
  Dim RowSrcCrnt As Integer
  Dim StartTime As Single
  Dim ValueList() As ValueDtl

  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual

  ' I have sized the array to more than I expect to require because ReDim
  ' Preserve is expensive.  However, I will resize if I fill the array.
  ' For my experiment I know exactly how many elements I need but that
  ' might not be true for you.
  ReDim ValueList(1 To 25000)

  NumSelect = 1
  ColDestCrnt = 1
  RowDestCrnt = 1
  InxVLCrntMax = 0      ' Last used element in ValueList.
  With Sheets("Time2")
    .Range("A1:T715").EntireRow.Delete
  End With
  StartTime = Timer
  With Sheets("Time1")
    Do While True
      ColSrcCrnt = (NumSelect Mod 20) + 1
      RowSrcCrnt = (NumSelect - ColSrcCrnt) / 20 + 1
      If RowSrcCrnt > 5000 Then
        Exit Do
      End If
      InxVLCrntMax = InxVLCrntMax + 1
      If InxVLCrntMax > UBound(ValueList) Then
        ' Resize array if it has been filled 
        ReDim Preserve ValueList(1 To UBound(ValueList) + 1000)
      End If
      With .Cells(RowSrcCrnt, ColSrcCrnt)
        ValueList(InxVLCrntMax).Value = .Value              ' Version 2
        ValueList(InxVLCrntMax).Value = .Formula            ' Version 3
        ValueList(InxVLCrntMax).Colour = .Font.Color
      End With
      NumSelect = NumSelect + 7
    Loop
  End With
  With Sheets("Time2")
    For InxVLCrnt = 1 To InxVLCrntMax
      With .Cells(RowDestCrnt, ColDestCrnt)
        .Value = ValueList(InxVLCrnt).Value                 ' Version 2
        .Formula = ValueList(InxVLCrnt).Value               ' Version 3
        .Font.Color = ValueList(InxVLCrnt).Colour
      End With
      If ColDestCrnt = 20 Then
        ColDestCrnt = 1
        RowDestCrnt = RowDestCrnt + 1
      Else
       ColDestCrnt = ColDestCrnt + 1
      End If
    Next
  End With
  Debug.Print Timer - StartTime
  ' Version 2 average 1.47 secs
  ' Version 3 average 1.83 secs
  Application.Calculation = xlCalculationAutomatic

End Sub

In excel, I am trying to copy text from one cell to another cell in another sheet. The source cell contains formatted text (bold,underlined,different colors). But when I copy the text using VBA to the other cell, the formatting is lost.

I know it is because excel is copying only the text value. Is there a way we can read the HTML text (rather than plain text) from a cell?

I have googled this and did not get any answers. I know that if we use copy and paste methods, we can copy the formatting.
E.g.

Range("F10").Select
Selection.Copy
Range("I10").Select
ActiveSheet.Paste

But I want to do it without a copy and paste since my destination is a merged cell and not identically sized as my source cell. Is there an option available in excel VBA to do this?

EDIT:
I was able to solve it with the following code.

Range("I11").Value = Range("I10").Value
For i = 1 To Range("I10").Characters.Count
    Range("I11").Characters(i, 1).Font.Bold = Range("I10").Characters(i, 1).Font.Bold
    Range("I11").Characters(i, 1).Font.Color = Range("I10").Characters(i, 1).Font.Color
    Range("I11").Characters(i, 1).Font.Italic = Range("I10").Characters(i, 1).Font.Italic
    Range("I11").Characters(i, 1).Font.Underline = Range("I10").Characters(i, 1).Font.Underline
    Range("I11").Characters(i, 1).Font.FontStyle = Range("I10").Characters(i, 1).Font.FontStyle
Next i

Если вы хотите скопировать только форматирование ячейки из диапазона, как это сделать быстро? В этом руководстве представлены быстрые сокращения, позволяющие легко копировать только форматирование.

Копирование форматирования только с помощью Format Painter в Excel

Копировать форматирование только с помощью VBA

Копировать форматирование только с Kutools for Excel

Копирование форматирования только с помощью Format Painter в Excel

В Excel вы можете копировать форматирование ячеек только с помощью Формат Painter инструмент.

1. Выберите диапазон, содержащий формат ячеек, который вы хотите скопировать. Смотрите скриншот:

2. Применение Формат Painter щелкнув его под Главная вкладку, см. снимок экрана:

3. Выберите пустую ячейку и щелкните по ней, будет вставлено только форматирование ячеек. Смотрите скриншот:

Внимание: Формат Painter также можно копировать форматирование только на другой лист.

Копировать форматирование только с помощью VBA

Следующие макросы также могут помочь вам скопировать только форматирование ячеек.

1. Держать ALT и нажмите F11 на клавиатуре, чтобы открыть Microsoft Visual Basic для приложений окно.

2. Нажмите Вставить > Модули, и скопируйте VBA в модуль.

VBA: копировать только форматирование ячеек:

Sub CopyFormat()
'Update 20130815
Dim CopyRng As Range, PasteRng As Range
xTitleId = "KutoolsforExcel"
Set CopyRng = Application.Selection
Set CopyRng = Application.InputBox("Ranges to be copied :", xTitleId, CopyRng.Address, Type:=8)
Set PasteRng = Application.InputBox("Paste to (single cell):", xTitleId, Type:=8)
CopyRng.Copy
PasteRng.Parent.Activate
PasteRng.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End Sub

3. Нажмите Run или нажмите F5 для запуска VBA. На экране отображается диалоговое окно, и вы должны выбрать ячейки, форматирование которых вы хотите скопировать. Смотрите скриншот:

4. Нажмите Ok и другое диалоговое окно отображается для вас, чтобы выбрать ячейку для вставки форматирования. Смотрите скриншот:

6. Нажмите Ok, то форматирование ячеек вставляется в выбранную ячейку. Смотрите скриншот:

 Внимание: С помощью этого кода VBA вы можете вставлять только форматирование в другие рабочие листы, которые вы хотите.

Копировать форматирование только с Kutools for Excel

Есть Kutools for Excel установлен, Копировать диапазоны Функция может помочь вам быстро и легко скопировать только форматирование ячеек.

После установки Kutools for Excel, пожалуйста, сделайте, как показано ниже Бесплатная загрузка Kutools for Excel Сейчас!)

Пожалуйста, примените Копировать диапазоны функция, нажав Кутулс > Копировать диапазоны. Смотрите скриншот:

1. Выделите ячейки, форматирование которых вы хотите скопировать.

2. Нажмите Кутулс > Копировать диапазонs, на экране появится диалог, отметьте Форматы вариант под Специальная вставка, см. снимок экрана:

3. И нажмите ОК. Другой диалог отображается для вас, чтобы выбрать ячейку для вставки результата. Смотрите скриншот:

4. Нажмите Ok, и в выбранную ячейку вставляется только форматирование. Смотрите скриншот:

Внимание: Вы также можете копировать и вставлять форматирование ячеек между двумя электронными таблицами. Если вы хотите скопировать высоту строки и ширину столбца, вы можете проверить Включая высоту строки и Включая ширину столбца коробка в Копировать несколько диапазонов Диалог.

Работы С Нами Kutools for Excel‘ Копировать диапазоны, вы также можете копировать только значения, формулы или комментарии.

Наконечник.Если вы хотите подсчитать или суммировать ячейки на основе цветов, попробуйте использовать Kutools for ExcelАвтора Считать по цвету как показано на следующем снимке экрана. Полная функция без ограничений в 30 дней, пожалуйста, скачайте и получите бесплатную пробную версию сейчас.

Относительные статьи:

• Копировать числа без формул в ячейки
• Копировать только комментарии из ячеек в другую
• Копировать значения и форматирование в ячейки

Должен заметить, что исходный код был совсем не таким, нежели код с локализованной проблемой. Он был намного сложнее. И чтобы его разобрать, нужно было бы копировать 2 экрана исходников. В ряд ли кому-то интересно читать этот бред. Вот результат в одну -две строки, который я дал, мне кажется как раз тот вариант, который достоин публикации на форуме. Или не прав?
Вот весь код:
Public Function aa(aa1 As Integer, aa2 As String) ‘Печать типа
‘aa1 — номер печатаемого типа.
‘aa2 — номер раздела, содержимое которого заполнит таблицу
Const aa3 = 8 ‘ номер строки, с которой рисуется шапка таблицы на листе отрисовки
Const aa4 = 11 ‘ номер колонки, с которой рисуется шапка таблицы на листе
Dim aa5 As Integer ‘ номер строки по листу типы
Dim aa6 As Integer ‘ номер очередного типа в таблице типов
Dim aa7 As Byte ‘ номер активной версии таблицы
Const aa8 = 1 ‘ номер колонки, на листе описателе типов, в которой проставлены номера типов
Const aa9 = 11 ‘ номер строки на листе описателе типов, с которой проставлены номера типов
Dim aa10 As Integer ‘ номер первой строки, принадлежащей данному типу на листе описателе типов
Dim aa11 As Integer ‘ номер текущего типа на листе описателе типов
Dim aa12 As Integer ‘ номер очередной строки, принадлежащей данному типу на листе описателе типов
Const aa13 = 10 ‘ номер колонки, с которой отрисовывается генерируемая таблица
Dim aa14 As Byte ‘ номер колонки, в которой отрисовывается обрабатываемое поле рисуемой таблицы
Const aa15 = 19 ‘номер колонки с текстовым описанием шапок таблиц в таблице-описателе типов.
‘Const aa16 = «Экран» ‘ лист, на котором отрисовывается таблица
Dim aa17 As String ‘шапка очередной колонки
Dim aa18 As Byte ‘ ширина очередного столбца
Const aa19 = 12 ‘ номер колонки, в которую прописывается ширина колонок в описателе таблиц
Const aa20 = 25 ‘ номер колонки, в которую прописывается формат ячеек колонок в описателе таблиц
Dim aa21 As Range ‘формат ячеек
aa5 = 10
aa6 = Worksheets(«Типы»).Cells(aa5, 2)

While aa6 <> 0 And aa6 <> aa1
aa5 = aa5 + 1
aa6 = Worksheets(«Типы»).Cells(aa5, 2)
Wend
If aa6 <> 0 Then ‘значит тип идентифицирован. он в aa5 строке
aa7 = Worksheets(«Типы»).Cells(aa6, 9)
If aa7 = 0 Then Worksheets(«Типы»).Cells(aa6, 9) = 1: aa7 = 1 ‘если версия не проставлена- значит проставить первую
aa10 = aa9
aa11 = Worksheets(«Описатель типов»).Cells(aa10, aa8)
While aa11 <> 0 And aa11 <> aa1
aa10 = aa10 + 1
aa11 = Worksheets(«Описатель типов»).Cells(aa10, aa8)
Wend
If aa11 = aa1 Then ‘найдена соответствующая строка в таблице-описателе типов.
‘Прорисовываем шапку раздела
aa12 = aa10
aa11 = Worksheets(«Описатель типов»).Cells(aa12, aa8)
While aa11 = aa1
aa14 = aa13 — 1 + Worksheets(«Описатель типов»).Cells(aa12, 2 + aa7)
aa17 = Worksheets(«Описатель типов»).Cells(aa12, aa15)
Worksheets(aa16).Cells(aa3, aa14) = aa17
aa18 = Worksheets(«Описатель типов»).Cells(aa12, 12)
‘прорисовка формата заголовка (with не использую, так как тут тоже глюки были, решил коряво прописать — лишь бы работало.
Worksheets(aa16).Cells(aa3, aa14).ColumnWidth = aa18
Worksheets(aa16).Cells(aa3, aa14).NumberFormat = «@»
Worksheets(aa16).Cells(aa3, aa14).HorizontalAlignment = xlCenter
Worksheets(aa16).Cells(aa3, aa14).VerticalAlignment = xlCenter
Worksheets(aa16).Cells(aa3, aa14).WrapText = True
Worksheets(aa16).Cells(aa3, aa14).Orientation = 90
Worksheets(aa16).Cells(aa3, aa14).AddIndent = False
Worksheets(aa16).Cells(aa3, aa14).IndentLevel = 0
Worksheets(aa16).Cells(aa3, aa14).ShrinkToFit = False
Worksheets(aa16).Cells(aa3, aa14).ReadingOrder = xlContext
Worksheets(aa16).Cells(aa3, aa14).MergeCells = False
‘копирование формата ячеек колонки в первую строку данных

[COLOR=skyblue]aa21 = Worksheets(«Описатель типов»).Range(Cells(aa12, aa20), Cells(aa12, aa20))[/COLOR]’ эта строка и есть причина ошибки. Она прописывалась по разному, в том числе и через Copy.
Worksheets(aa16).Cells(aa3 + 2, aa14) = aa21
aa12 = aa12 + 1
aa11 = Worksheets(«Описатель типов»).Cells(aa12, aa8)
Wend
Else
‘нет такого типа в таблице описания известных типов
End If

Else
‘нет такого типа в таблице известных типов
End If
End Function

Ну как? Извиняюсь за корявое программирование. Варюсь в собственном соку. И книг по VBA и объектному программированию не читал.