cách nhanh để sao chép định dạng trong excel

Question

Tôi có hai bit mã. Lần đầu tiên một bản sao tiêu chuẩn dán từ tế bào A đến tế bào B

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

tôi có thể làm gần như giống nhau sử dụng

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

Bây giờ Phương pháp thứ hai này là nhanh hơn nhiều, tránh sao chép vào clipboard và dán lại. Tuy nhiên nó không sao chép trên định dạng như phương thức đầu tiên. Phiên bản thứ hai là gần như ngay lập tức để sao chép 500 dòng, trong khi phương pháp đầu tiên thêm khoảng 5 giây cho đến thời điểm đó. Và phiên bản cuối cùng có thể lên tới 5000 ô.

Vì vậy, câu hỏi của tôi có thể thay đổi dòng thứ hai để bao gồm định dạng ô (chủ yếu là màu phông chữ) trong khi vẫn ở nhanh. Lý tưởng nhất là tôi muốn có thể sao chép các giá trị ô vào một mảng/danh sách cùng với định dạng phông chữ để tôi có thể thực hiện sắp xếp và thao tác trên chúng trước khi tôi "dán" chúng trở lại trang tính.

Vì vậy, giải pháp lý tưởng của tôi sẽ có một số điều như

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 

là nó có thể sử dụng chuỗi RTF trong VBA hoặc là chỉ có thể trong vb.net vv

trả lời *

Chỉ cần để xem làm thế nào Phương pháp origianl của tôi và phương pháp compar mới, đây là những kết quả hoặc trước và sau khi

Code mới = 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 

Cũ code = 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 

Answer 1

Đối với tôi, bạn không thể. Nhưng nếu điều đó phù hợp với nhu cầu của bạn, bạn có thể có tốc độ và định dạng bằng cách sao chép toàn bộ phạm vi cùng một lúc, thay vì vòng lặp:

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

Và, bằng cách này, bạn có thể xây dựng một chuỗi nhiều tùy chỉnh, như Range("B2:B4, B6, B11:B18")

---

chỉnh sửa: nếu nguồn của bạn là "thưa thớt", có thể bạn không chỉ cần định dạng điểm đến cùng một lúc khi copy xong?

Answer 2

Có:

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

... hoạt động? (Tôi không có Excel trước mặt tôi, vì vậy không thể kiểm tra.)

Answer 3

Hãy nhớ rằng khi bạn viết:

MyArray = Range("A1:A5000") 

bạn đang thực sự viết

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

Bạn cũng có thể sử dụng các tên:

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

Nhưng giá trị gia tăng không phải là tài sản duy nhất của Dải . Tôi đã sử dụng:

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

tôi nghi ngờ

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

sẽ làm việc nhưng tôi mong chờ

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

để làm việc.

Tôi không biết bạn muốn sao chép định dạng nào để bạn sẽ phải thử.

Tuy nhiên, tôi phải thêm rằng khi bạn sao chép và dán một phạm vi rộng, nó không chậm hơn nhiều so với thực hiện nó thông qua một mảng như chúng ta đều nghĩ.

bài viết Chỉnh sửa thông tin

Sau khi đăng ở trên tôi đã cố gắng bằng cách tư vấn riêng. Các thí nghiệm của tôi với việc sao chép Font.Color và Font.Bold thành một mảng đã thất bại.

Trong các câu sau đây, thứ hai sẽ thất bại với một loại không phù hợp:

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

ValueArray phải có loại biến thể. Tôi đã thử cả hai biến thể và dài cho ColourArray mà không thành công.

tôi điền ColourArray với các giá trị và cố gắng tuyên bố sau:

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

Toàn bộ phạm vi sẽ được tô màu theo các yếu tố đầu tiên của ColourArray và sau đó Excel looped tiêu thụ khoảng 45% thời gian xử lý cho đến khi tôi chấm dứt nó với Task Manager.

Có một hình phạt thời gian liên quan đến việc chuyển đổi giữa các trang tính nhưng các câu hỏi gần đây về thời lượng macro đã khiến mọi người xem xét niềm tin của chúng tôi rằng hoạt động qua mảng nhanh hơn đáng kể.

Tôi đã tạo thử nghiệm phản ánh rộng yêu cầu của bạn. Tôi đã điền vào bảng tính Time1 với 5000 hàng 20 ô được định dạng có chọn lọc như: in đậm, in nghiêng, gạch dưới, chỉ số, có viền, đỏ, lục, lam, nâu, vàng và xám-80%.

Với phiên bản 1, tôi đã sao chép mọi ô thứ 7 từ trang tính "Time1" vào trang tính "Time2" bằng bản sao.

Với phiên bản 2, tôi đã sao chép mọi ô thứ 7 từ trang tính "Time1" sang trang tính "Time2" bằng cách sao chép giá trị và màu qua mảng.

Với phiên bản 3, tôi sao chép mọi ô thứ 7 từ trang tính "Time1" vào trang tính "Time2" bằng cách sao chép công thức và màu sắc qua mảng.

Phiên bản 1 mất trung bình 12,43 giây, phiên bản 2 mất trung bình 1,47 giây trong khi phiên bản 3 mất trung bình 1,83 giây. Công thức sao chép phiên bản 1 và tất cả các định dạng, giá trị và màu được sao chép của phiên bản 2 trong khi công thức và màu sắc được sao chép phiên bản 3. Với phiên bản 1 và 2, bạn có thể thêm đậm và nghiêng, nói, và vẫn còn một thời gian trong tay. Tuy nhiên, tôi không chắc chắn nó sẽ có giá trị bận tâm cho rằng sao chép 21.300 giá trị chỉ mất 12 giây.

** Mã cho phiên bản 1 **

Tôi không nghĩ mã này bao gồm mọi thứ cần giải thích. Trả lời nhận xét nếu tôi sai và tôi sẽ sửa.

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 

** Mã cho phiên bản 2 và loại 3 nét **

Người dùng phải được đặt trước bất kỳ chương trình con trong mô-đun. Mã hoạt động thông qua các giá trị sao chép bảng tính nguồn hoặc công thức và màu sắc cho phần tử tiếp theo của mảng. Sau khi lựa chọn đã hoàn thành, nó sẽ sao chép thông tin đã thu thập vào trang tính đích. Điều này tránh chuyển đổi giữa các trang tính nhiều hơn là điều cần thiết.

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 

Answer 4

Bạn có thể chỉ đơn giản là sử dụng Range("x1").value(11) một cái gì đó như dưới đây:

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

phạm vi có tính mặc định "giá trị" cộng với giá trị có thể có 3 tùy chọn orguments 10,11,12. 11 là những gì bạn cần để xem cả giá trị và định dạng. Nó không sử dụng clipboard vì vậy nó nhanh hơn - Durgesh

Answer 5

Chỉ sử dụng thuộc tính NumberFormat sau thuộc tính Value: Trong ví dụ này, các Ranges được xác định bằng các biến gọi là ColLetter và SheetRow. sử dụng số nguyên i, nhưng chúng có thể là các phạm vi được xác định thông thường.

TransferSheet.Range (ColLetter & SheetRow) .Value = Range (ColLetter & i) .Value TransferSheet.Range (ColLetter & SheetRow) .NumberFormat = Range (ColLetter & i) .NumberFormat