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
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?
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