मेरे पास एक वर्कशीट "सूची" है जिसमें डेटा की पंक्तियां हैं जिन्हें मुझे अन्य कार्यपत्रकों में कॉपी करने की आवश्यकता है। "सूची" के कॉलम "जे" में, एक नाम (मैथ्यू, मार्क, लिंडा, आदि) है जो निर्दिष्ट करता है कि पंक्ति किसका डेटा है।

उनमें से प्रत्येक नाम (कुल 22) में एक ही नाम के साथ मेल खाने वाली स्प्रेडशीट है। मैं वर्कशीट "लिंडा" में पेस्ट करने के लिए कॉलम "जे" में "लिंडा" कहने वाली सभी पंक्तियां चाहता हूं, वर्कशीट "मैथ्यू" आदि में पेस्ट करने के लिए "मैथ्यू" वाली सभी पंक्तियां।

मेरे पास नीचे कुछ कोड है, जो ज्यादातर काम करता है, लेकिन मुझे इसे सभी 22 नामों/पत्रकों के लिए फिर से लिखना होगा।

क्या मिलान करने वाले नामों के साथ पंक्तियों को चिपकाने, सभी शीटों के माध्यम से लूप करने का कोई तरीका है? साथ ही, नीचे दिया गया कोड वास्तव में धीरे-धीरे काम करता है, और मैं 200 से 60,000 पंक्तियों के साथ कहीं भी डेटा सेट का उपयोग कर रहा हूं, जिन्हें सॉर्ट और पेस्ट करने की आवश्यकता है, जिसका अर्थ है कि यदि यह एक छोटे डेटा सेट पर धीमा है जैसे कि मैं वर्तमान में काम कर रहा हूं, और केवल एक शीट के लिए, यह बड़े डेटा सेट के लिए हिमनद रूप से धीमा होने वाला है।

Sub CopyMatch()
    Dim c As Range
    Dim j As Integer
    Dim Source As Worksheet
    Dim Target As Worksheet

    Set Source = Worksheets("List")
    Set Target = Worksheets("Linda")

    j = 4     ' Start copying to row 1 in target sheet
    For Each c In Source.Range("J4:J1000")   ' Do 1000 rows
        If c = "Linda" Then
           Source.Rows(c.Row).Copy Target.Rows(j)
           j = j + 1
        End If
    Next c
End Sub
2
user4907546 11 मार्च 2017, 01:18

2 जवाब

सबसे बढ़िया उत्तर

जब तक आपने गणना को कहीं बंद नहीं किया है, हम यहां नहीं देख सकते हैं, तो हर बार जब आप एक पंक्ति की प्रतिलिपि बनाते हैं, तो एक्सेल पुनर्गणना कर रहा है - भले ही आपकी शीट में कोई सूत्र न हो।

यदि आप पहले से ऐसा नहीं कर रहे हैं, तो सीधे शब्दों में कहें:

application.calculation=xlcalculationmanual

अपना लूप शुरू करने से पहले और:

application.calculation=xlcalculationautomatic

लूप से बाहर निकलने के बाद आपके लूप को बड़े पैमाने पर गति मिलेगी। अतिरिक्त स्वैंक के लिए, आप गणना सेटिंग को बंद करने से पहले उसे स्टोर करने के लिए एक चर का उपयोग कर सकते हैं और अंत में उस सेटिंग को पुनर्स्थापित कर सकते हैं, उदा।

dim lCalc as long
lCalc = application.calculation
application.calculation = xlcalculationmanual
for ... next goes here
application.calculation = lCalc

अन्य सेटिंग्स पर भी विचार करें, जैसे: application.screenupdating=False|True।

आप जिस नाम का चयन कर रहे हैं, उसके आधार पर डेटा को क्रमबद्ध करें, फिर किसी अन्य प्रकार से जो आप चाहते हैं। इस तरह आप 22 चरणों में किसी भी आकार की शीट को छोड़ सकते हैं (क्योंकि आप कहते हैं कि आपके पास 22 नाम हैं)।

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

अपने नाम कॉलम में मान मानते हुए, जिस श्रेणी की आप जांच कर रहे हैं, वह हमेशा 22 नामों में से एक है, फिर यदि आपने उस कॉलम से पहले क्रमबद्ध किया है तो आप गंतव्य को निर्धारित करने के लिए उस कॉलम में मान का उपयोग कर सकते हैं, उदाहरण:

dim sTarget as string
dim rng as range
sTarget = ""
For Each c In Source.Range("J4:J1000") ' Do 1000 rows
    if c <> "" then ' skip empty rows
        if c <> sTarget then ' new name block
            sTarget = c
            Set Target = Worksheets(c)
            set rng = Target.cells(Target.rows.count, 10).end(xlup) ' 10="J"
            j = rng.row + 1 ' first row below last name pasted
        end if
        Source.Rows(c.Row).Copy Target.Rows(j)
        j = j + 1
    end if
Next

यह स्मृति के लिए किफायती है क्योंकि आप पंक्ति दर पंक्ति जा रहे हैं, लेकिन फिर भी यथोचित रूप से तेज़ हैं क्योंकि आप केवल लक्ष्य की पुनर्गणना कर रहे हैं और नाम बदलने पर j को रीसेट कर रहे हैं।

1
Winterknell 11 मार्च 2017, 03:26

आप उपयोग कर सकते हैं:

  • Dictionary कॉलम J नामों में से अद्वितीय नामों की सूची शीघ्रता से बनाने पर आपत्ति करें

  • प्रत्येक नाम पर फ़िल्टर करने के लिए AutoFilter() Range ऑब्जेक्ट की विधि:

निम्नलिखित नुसार

    Option Explicit

    Sub CopyMatch()
        Dim c As Range, namesRng As Range
        Dim name As Variant

        With Worksheets("List") '<--| reference "List" worskheet
            Set namesRng = .Range("J4", .Cells(.Rows.count, "J").End(xlUp)) '<--| set the range of "names" in column "J" starting from row 4 down to last not empty row
        End With

        With CreateObject("Scripting.Dictionary") '<--| instance a 'Dictionary' object
            For Each c In namesRng.SpecialCells(xlCellTypeConstants, xlTextValues) '<--| loop through "names" range cells with text content only
                .item(c.Value) = c.Value '<--| build the unique list of names using dictionary key
            Next
            Set namesRng = namesRng.Resize(namesRng.Rows.count + 1).Offset(-1) '<--| resize the range of "names" to have a "header" cell (not a name to filter on) in the first row
            For Each name In .Keys '<--| loop through dictionary keys, i.e. the unique names list
                FilterNameAndCopyToWorksheet namesRng, name '<--| filter on current name and copy to corresponding worksheet
            Next
        End With '<--| release the 'Dictionary' object
    End Sub

    Sub FilterNameAndCopyToWorksheet(rangeToFilter As Range, nameToFilter As Variant)
        Dim destsht As Worksheet

        Set destsht = Worksheets(nameToFilter) '<--| set the worksheet object corresponding to passed name
        With rangeToFilter
            .AutoFilter Field:=1, Criteria1:=nameToFilter
            Intersect(.Parent.UsedRange, .Resize(.Rows.count - 1).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow).Copy destsht.Cells(destsht.Rows.count, "J").End(xlUp)
            .Parent.AutoFilterMode = False
        End With
    End Sub
1
user3598756 11 मार्च 2017, 10:50