cara cepat untuk menyalin format di excel

Saya memiliki dua potongan kode. Pertama copy paste standar dari sel A ke sel B

Sheets(sheet_).Cells(x, 1).Copy Destination:=Sheets("Output").Cells(startrow, 2)

Saya bisa melakukan hal yang hampir sama menggunakan

Sheets("Output").Cells(startrow, 2) = Sheets(sheet_).Cells(x, 1)

Sekarang metode kedua ini jauh lebih cepat, menghindari penyalinan ke clipboard dan menempelkan lagi. Namun, metode ini tidak menyalin seluruh pemformatan seperti yang dilakukan metode pertama. Versi kedua hampir instan untuk menyalin 500 baris, sementara metode pertama menambahkan sekitar 5 detik ke waktu. Dan versi terakhir bisa lebih dari 5000 sel.

Jadi pertanyaan saya, bisakah baris kedua diubah untuk memasukkan pemformatan sel (terutama warna font) sambil tetap cepat.

Idealnya saya ingin dapat menyalin nilai sel ke array / daftar bersama dengan pemformatan font sehingga saya dapat melakukan penyortiran dan operasi lebih lanjut pada mereka sebelum saya " paste &" mereka kembali ke lembar kerja ...

Jadi solusi ideal saya adalah beberapa hal seperti

for x = 0 to 5000
array(x) = Sheets(sheet_).Cells(x, 1) 'including formatting
next

for x = 0 to 5000
Sheets("Output").Cells(x, 1)
next

apakah mungkin untuk menggunakan string RTF di VBA atau hanya mungkin di vb.net, dll.

*Jawaban**

Sekedar untuk melihat perbandingan metode awal dan metode baru saya, berikut adalah hasil atau sebelum dan sesudahnya

Kode baru = 65msec

Sheets("Output").Cells(startrow, 2) = Sheets(sheet_).Cells(x, 1)
Sheets("Output").Range("B" & startrow).Font.ColorIndex = Sheets(sheet_).Range("A" & x).Font.ColorIndex 'copy font colour as well

Kode lama = 1296msec

'Sheets("Output").Cells(startrow, 2).Value = Sheets(sheet_).Cells(x, 1)
'Sheets(sheet_).Cells(x, 1).Copy
'Sheets("Output").Cells(startrow, 2).PasteSpecial (xlPasteFormats)
'Application.CutCopyMode = False
DevilWAH
Pertanyaan edit 23 Desember 2011 в 9:12
Pemrograman
vba copy format rtf
23 Desember 2011 в 2:27
1 tampilan
Larutan

Bagi saya, Anda tidak bisa. Tetapi jika itu sesuai dengan kebutuhan Anda, Anda bisa mendapatkan kecepatan dan pemformatan dengan menyalin seluruh rentang sekaligus, alih-alih mengulang:

range("B2:B5002").Copy Destination:=Sheets("Output").Cells(startrow, 2)

Dan, omong-omong, Anda bisa membuat string rentang khusus, seperti Range("B2:B4, B6, B11:B18")

edit: jika sumber Anda "sparse", tidak bisakah Anda hanya memformat tujuan sekaligus ketika penyalinan selesai?

Patrick Honorez
Jawaban edit 23 Desember 2011 в 3:08
Komentar (8)

Ingatlah bahwa ketika Anda menulis:

MyArray = Range("A1:A5000")

Anda benar-benar menulis

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

Anda juga bisa menggunakan nama:

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

Tetapi Nilai bukan satu-satunya properti Range. Saya telah menggunakan:

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

Saya ragu

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

akan bekerja tetapi saya berharap

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

untuk bekerja.

Saya tidak tahu format apa yang ingin Anda salin, jadi Anda harus mencobanya.

Namun, saya harus menambahkan bahwa ketika Anda menyalin dan menempelkan rentang yang besar, itu tidak lebih lambat daripada melakukannya melalui array seperti yang kita semua pikirkan.

Pasca Edit informasi

Setelah memposting hal di atas, saya mencoba dengan saran saya sendiri. Percobaan saya dengan menyalin Font.Color dan Font.Bold ke array telah gagal.

Dari pernyataan-pernyataan berikut, pernyataan kedua akan gagal dengan ketidakcocokan tipe:

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

ValueArray harus dari tipe varian. Saya mencoba kedua varian dan long untuk ColourArray tanpa berhasil.

Saya mengisi ColourArray dengan nilai dan mencoba pernyataan berikut:

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

Seluruh rentang akan diwarnai sesuai dengan elemen pertama ColourArray dan kemudian Excel berputar-putar menghabiskan sekitar 45% waktu prosesor sampai saya menghentikannya dengan Task Manager.

Ada penalti waktu yang terkait dengan peralihan antar lembar kerja, tetapi pertanyaan baru-baru ini tentang durasi makro telah menyebabkan semua orang meninjau kembali keyakinan kami bahwa bekerja melalui array secara substansial lebih cepat.

Saya membuat percobaan yang secara luas mencerminkan kebutuhan Anda. Saya mengisi lembar kerja Time1 dengan 5000 baris 20 sel yang diformat secara selektif sebagai: tebal, miring, garis bawah, subskrip, berbatas, merah, hijau, biru, coklat, kuning dan abu-abu-80%.

Dengan versi 1, saya menyalin setiap sel ke-7 dari lembar kerja " Time1 &" ke lembar kerja " Time2 &" menggunakan salinan.

Dengan versi 2, saya menyalin setiap sel ke-7 dari lembar kerja "Time1 &" ke lembar kerja "Time2 &" dengan menyalin nilai dan warnanya melalui array.

Dengan versi 3, saya menyalin setiap sel ke-7 dari lembar kerja "Time1 &" ke lembar kerja "Time2 &" dengan menyalin rumus dan warnanya melalui array.

Versi 1 membutuhkan waktu rata-rata 12.43 detik, versi 2 membutuhkan waktu rata-rata 1.47 detik sedangkan versi 3 membutuhkan waktu rata-rata 1.83 detik. Versi 1 menyalin rumus dan semua pemformatan, versi 2 menyalin nilai dan warna sementara versi 3 menyalin rumus dan warna. Dengan versi 1 dan 2, Anda bisa menambahkan huruf tebal dan miring, katakanlah, dan masih memiliki waktu. Namun, saya tidak yakin itu akan sepadan dengan repot-repotnya mengingat bahwa menyalin 21.300 nilai hanya membutuhkan waktu 12 detik.

Kode untuk Versi 1

Saya rasa kode ini tidak mencakup apa pun yang membutuhkan penjelasan. Tanggapi dengan komentar jika saya salah dan saya akan memperbaikinya.

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

Kode untuk Versi 2 dan 3

Definisi tipe pengguna harus ditempatkan sebelum subrutin dalam modul. Kode ini bekerja melalui lembar kerja sumber yang menyalin nilai atau rumus dan warna ke elemen berikutnya dari array. Setelah pemilihan selesai, ia menyalin informasi yang dikumpulkan ke lembar kerja tujuan. Hal ini menghindari peralihan antara lembar kerja lebih dari yang penting.

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
Tony Dallimore
Jawaban edit 26 Desember 2011 в 10:19
Komentar (0)

Apakah:

Set Sheets("Output").Range("$A$1:$A$500") =  Sheets(sheet_).Range("$A$1:$A$500")

...bekerja? (Saya tidak memiliki Excel di depan saya, jadi tidak bisa mengujinya).

Komentar (3)