एक्सेल में स्वरूपण की प्रतिलिपि बनाने के लिए तेज़ तरीका

Question

मेरे पास कोड के दो बिट हैं। सबसे पहले एक मानक प्रतिलिपि सेल एक से पेस्ट सेल बी

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

को मैं का उपयोग कर

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

अब इस दूसरी विधि तेज हो गया है लगभग एक ही कर सकते हैं, नकल से बचने क्लिपबोर्ड में और फिर चिपकाने। हालांकि यह पहली विधि के रूप में स्वरूपण में प्रतिलिपि नहीं करता है। दूसरा संस्करण 500 लाइनों की प्रतिलिपि बनाने के लिए लगभग तुरंत है, जबकि पहली विधि उस समय के बारे में 5 सेकंड जोड़ती है। और अंतिम संस्करण 5000 कोशिकाओं के ऊपर हो सकता है।

तो मेरा प्रश्न सेल स्वरूपण (मुख्य रूप से फ़ॉन्ट रंग) को शामिल करने के लिए दूसरी पंक्ति को बदला जा सकता है जबकि अभी भी तेजी से रह रहा है।

आदर्श रूप से मैं सेल मानों को फ़ॉन्ट स्वरूपण के साथ एक सरणी/सूची में कॉपी करने में सक्षम होना चाहता हूं ताकि मैं उन्हें वर्कशीट पर वापस "पेस्ट" करने से पहले आगे सॉर्टिंग और संचालन कर सकूं ..

तो मेरी आदर्श समाधान की तरह

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 

कुछ बात होगी यह VBA में आरटीएफ तार का उपयोग करना संभव है, आदि है या कि केवल vb.net में संभव है

उत्तर *

बस कैसे मेरे origianl विधि और नई विधि compar, यहाँ के परिणाम हैं या पहले और बाद में

नए कोड = 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 

पुराने कोड = 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

मेरे लिए, आप नहीं कर सकते। लेकिन यदि सूट अपनी आवश्यकताओं, आप गति और एक ही बार में पूरी श्रृंखला को कॉपी करके स्वरूपण, पाशन के बजाय हो सकता है:

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

और, वैसे, आप एक कस्टम रेंज स्ट्रिंग निर्माण कर सकते हैं Range("B2:B4, B6, B11:B18") की तरह,

---

संपादित: यदि आपका स्रोत "विरल" है, तो आप सिर्फ गंतव्य पर एक बार जब प्रतिलिपि समाप्त हो गया है स्वरूपित नहीं कर सकते?

Answer 2

करता है:

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

... काम? (मेरे पास एक्सेल मेरे सामने नहीं है, इसलिए परीक्षण नहीं कर सकता।)

Answer 3

याद रखें कि जब आप लिखते हैं:

MyArray = Range("A1:A5000") 

तुम सच में

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

लिख रहे हैं आप भी नाम का उपयोग कर सकते हैं:

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

लेकिन मान की की ही संपत्ति नहीं है । मैं का इस्तेमाल किया है:

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

मैं

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

शक काम करेगा लेकिन मैं

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

काम करने की उम्मीद होगी।

मुझे नहीं पता कि आप किस प्रारूप को प्रतिलिपि बनाना चाहते हैं, इसलिए आपको कोशिश करनी होगी।

हालांकि, मुझे यह जोड़ना होगा कि जब आप एक बड़ी रेंज की प्रतिलिपि बनाते हैं और पेस्ट करते हैं, तो यह एक सरणी के माध्यम से ऐसा करने से धीमा नहीं है जैसा कि हम सभी ने सोचा था।

संदेश का संपादन करें जानकारी

तैनात करने के बाद ऊपर मैं खुद सलाह द्वारा की कोशिश की। Font.Color और Font.Bold की प्रतिलिपि बनाने के साथ मेरे प्रयोग एक सरणी में विफल हो गए हैं।

निम्नलिखित बयानों में से

, दूसरा एक प्रकार मेल नहीं खाता के साथ विफल हो जाएगा:

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

ValueArray प्रकार प्रकार का होना चाहिए। मैंने बिना सफलता के कलरएरे के लिए दोनों प्रकार और लंबे समय तक प्रयास किया।

मैं मूल्यों के साथ ColourArray भरा है और निम्नलिखित बयान करने की कोशिश की:

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

संपूर्ण रेंज ColourArray और फिर एक्सेल के पहले तत्व के अनुसार रंग का हो जाएगा फंस प्रोसेसर समय का लगभग 45% लेने जब तक मैं समाप्त यह कार्य प्रबंधक के साथ।

वर्कशीट्स के बीच स्विचिंग के साथ जुड़ा हुआ समय जुर्माना है लेकिन मैक्रो अवधि के बारे में हालिया प्रश्नों से सभी ने हमारे विश्वास की समीक्षा की है कि सरणी के माध्यम से काम करना काफी तेज़ था।

मैंने एक प्रयोग बनाया जो व्यापक रूप से आपकी आवश्यकता को दर्शाता है। मैंने वर्कशीट टाइम 1 को 20 कोशिकाओं की 5000 पंक्तियों के साथ भर दिया जिन्हें चुनिंदा रूप से स्वरूपित किया गया था: बोल्ड, इटैलिक, अंडरलाइन, सबस्क्रिप्ट, बोर्डर्ड, लाल, हरा, नीला, भूरा, पीला और भूरा -80%।

संस्करण 1 के साथ, मैंने वर्कशीट "टाइम 1" से प्रत्येक 7 वीं कोशिकाओं को प्रतिलिपि बनाकर "टाइम 2" की प्रतिलिपि बनाई।

संस्करण 2 के साथ, मैं "समय 2" वर्कशीट के लिए मूल्य और एक सरणी के माध्यम से रंग को कॉपी करके वर्कशीट "समय 1" से हर 7 वें कोशिकाओं की नकल की।

संस्करण 3 के साथ, मैं "समय 2" कार्यपत्रक में सूत्र और एक सरणी के माध्यम से रंग को कॉपी करके वर्कशीट "समय 1" से हर 7 वें कोशिकाओं की नकल की।

संस्करण 1 12.43 सेकंड के एक औसत ले लिया, संस्करण 2 1.47 सेकंड के एक औसत ले लिया है, जबकि 3 संस्करण 1.83 सेकंड के एक औसत ले लिया। संस्करण 1 कॉपी किए गए सूत्र और सभी स्वरूपण, संस्करण 2 प्रतिलिपि मूल्य और रंग जबकि संस्करण 3 कॉपी किए गए सूत्र और रंग। संस्करण 1 और 2 के साथ आप बोल्ड और इटैलिक जोड़ सकते हैं, कहें, और अभी भी कुछ समय हाथ में है। हालांकि, मुझे यकीन नहीं है कि यह परेशान करने योग्य होगा कि 21,300 मूल्यों की प्रतिलिपि केवल 12 सेकंड लेती है।

** संस्करण 1 **

मैं इस कोड कुछ भी है कि एक स्पष्टीकरण की जरूरत है शामिल नहीं लगता है के लिए कोड। अगर मैं गलत हूं तो मैं एक टिप्पणी का जवाब दूंगा और मैं ठीक कर दूंगा।

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 

** संस्करण 2 और 3 **

उपयोगकर्ता प्रकार परिभाषा के लिए कोड मॉड्यूल में किसी भी सबरूटीन से पहले रखा जाना चाहिए। कोड सरणी के अगले तत्व में मूल्य वर्कशीट प्रतिलिपि मानों या सूत्रों और रंगों के माध्यम से काम करता है। एक बार चयन पूरा हो जाने के बाद, यह एकत्रित जानकारी को गंतव्य वर्कशीट में प्रतिलिपि बनाता है। यह आवश्यक है की तुलना में वर्कशीट्स के बीच स्विचिंग से बचाता है।

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

आप नीचे दिए गए जैसे Range("x1").value(11) कुछ इस्तेमाल किया जा सकता था:

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

रेंज सामान्य प्रॉपर्टी "मान" है प्लस मान 3 वैकल्पिक orguments 10,11,12 हो सकता है। 11 वह है जो आपको मूल्य और प्रारूप दोनों को बदलने की आवश्यकता है। यह क्लिपबोर्ड का उपयोग नहीं करता है तो यह faster.- है दुर्गेश

Answer 5

बस मूल्य संपत्ति के बाद NumberFormat संपत्ति का उपयोग करें: इस उदाहरण सीमाओं चर ColLetter और SheetRow कहा जाता है का उपयोग कर परिभाषित कर रहे हैं में और यह एक के लिए अगले पाश से आता है मैं पूर्णांक का उपयोग कर, लेकिन वे निश्चित रूप से सामान्य परिभाषित श्रेणियां हो सकती हैं।

TransferSheet.Range (ColLetter & SheetRow) .Value = रेंज (ColLetter & i) .Value TransferSheet.Range (ColLetter & SheetRow) .NumberFormat = रेंज (ColLetter & i)