कहीं एक स्क्रिप्ट है या एक्सेल को संशोधित करने का एक तरीका है जो कई चयनित क्षेत्रों को कॉपी और पेस्ट करने की अनुमति देता है?

Question

इसके पीछे प्रेरणा यह है कि एक्सेल में, कोशिकाओं के एक सेगमेंट को कॉपी करने के बाद आप केवल चयन से घटने की क्षमता के बिना अधिक कोशिकाओं को उजागर कर सकते हैं। इसने मुझे नाराज़ किया, इसलिए आज मैंने एक चयन से घटने के लिए एक vba स्क्रिप्ट लिखी जो एक से अधिक बार हाइलाइट की गई कोशिकाओं पर आधारित थी।

Sub MultiDeselect()
Dim rng As Range
Dim Uni As Range 'this is the union
Dim Intersct As Range
Dim UnionMinusIntersect As Range
Dim singleArea As Range

'MsgBox ActiveCell.Address
If Selection.Areas.Count > 1 Then
    For Each singleArea In Selection.Areas
        For Each rng In singleArea.Cells
            If Uni Is Nothing Then
                Set Uni = rng
            ElseIf Application.Intersect(Uni, rng) Is Nothing Then
                Set Uni = Union(Uni, rng)
            ElseIf Intersct Is Nothing Then
                Set Intersct = rng
            ElseIf Intersect(Intersct, rng) Is Nothing Then
                Set Intersct = Union(Intersct, rng)
            End If
        Next rng
    Next singleArea
'    MsgBox Uni.Address
    If Intersct Is Nothing Then
        Set UnionMinusIntersect = Uni
    Else
'        MsgBox Intersct.Address
        For Each singleArea In Uni
            For Each rng In singleArea.Cells
'                MsgBox rng.Address
                If Intersect(rng, Intersct) Is Nothing Then
                    If UnionMinusIntersect Is Nothing Then
                        Set UnionMinusIntersect = rng
                    Else
                        Set UnionMinusIntersect = Union(UnionMinusIntersect, rng)
                    End If
                End If
            Next rng
        Next singleArea
    End If
    'Check not null in case every cell was highlighted more than once
    If Not UnionMinusIntersect Is Nothing Then
        If UnionMinusIntersect.Cells.Count > 0 Then
            UnionMinusIntersect.Select
        End If
    End If
End If
End Sub

बहुत कुछ मेरे निराश होने पर, खत्म होने के बाद, मैंने पाया कि कई क्षेत्रों में नकल की अनुमति नहीं है, जो किसी चीज़ को उजागर करने के लिए मेरे सामान्य उद्देश्य को हरा देता है। इससे पहले कि मैं एक मल्टी-कॉपी और मल्टी-पेस्ट को लागू करने की कोशिश करूं, मैं जानना चाहता था कि क्या कोई पहले ही ऐसा कर चुका है। यह मूल रूप से सक्रिय सेल के शीर्ष बाईं ओर संबंधित सेल में चयन के शीर्ष बाएँ के सापेक्ष प्रत्येक सेल की प्रतिलिपि करेगा।

---

जॉर्डन का जवाब बहुत अच्छा काम करता है। यहां अंतिम आउटपुट का एक उदाहरण दिया गया है:

Comments

आम तौर पर मैं क्या कर बस का उपयोग किया जाता है Valueका उपयोग कर Cellsके साथ Rangeआप ऊपर, नीचे, बाएँ करना होगा, सही है अगर आप इसे में एक छेद चाहते हालांकि।

— ejbytes

एक क्रॉस का उपयोग करने के बारे में क्या। बाएँ से दाएँ, सीमा। अप डाउन, रेंज। चौराहे का क्षेत्र प्राप्त करें। केवल चौराहे क्षेत्र में प्रत्येक के लिए उपयोग करना और इसे एक सरणी में संग्रहीत करना। फिर अपने इच्छित क्षेत्र को दाएं से बाएं करें, सीमा, वह करें जो आप चाहते हैं कि चौराहे सहित पूरे क्षेत्र के साथ। फिर सरणी या सहेजे गए चौराहे क्षेत्र के साथ आप जो चाहें कर सकते हैं या पूर्ववत कर सकते हैं।

— ejbytes

Answer 1

दो सरल VB मैक्रो।

1. एक नया मैक्रो सक्षम कार्यपुस्तिका बनाएँ
2. नीचे दो मैक्रो बनाएँ।
3. कुछ कोशिकाओं में कुछ मान जोड़ें
4. DeselectCell मैक्रो चलाएँ
   • पहले वह संपूर्ण सीमा चुनें, जिसे आप प्रदान करना चाहते हैं, यदि आप नीचे से नमूना एक्सेल तालिका का उपयोग कर रहे हैं, तो आप दर्ज करेंगे: $A$1:$F$6और ठीक दबाएं।
   • अब आपको यह निर्दिष्ट करने की आवश्यकता है कि आप किन कक्षों का चयन करना चाहते हैं, बस एक सीमा निर्दिष्ट करने के लिए बाएं क्लिक करें। (Ctrl दबाए रखें और छोड़ें जाने के लिए कई श्रेणियां हैं। उदाहरण के लिए, दर्ज करें: $A$1,$C$2,$C$6और दबाएं ठीक है।
5. इस बिंदु पर, आपको अपनी छवि में ऊपर की तरह एक अचयनित सक्रिय क्षेत्र होना चाहिए । अब बस CopyMultipleSelection मैक्रो चलाएं और निर्दिष्ट करें कि आप किस सेल में परिणाम पेस्ट करना चाहते हैं। हमारे मामले में मान लीजिए $A$9, आपकी अंतिम प्रतिलिपि तालिका इस तरह दिखाई देगी:

अंतिम पास्ट की गई तालिका : (आपके पास एक _ के बजाय एक खाली सेल होगी, यह केवल प्रारूपण मुद्दों के कारण यहां के लिए है।

_   4   1   2   3   4
d   a   _   6   7   8
f   9   11  1   1   121
a   21  1   12  12  sa
b   a   a   sd  a   sa
324 234 _   23  423 42

सैंपल एक्सेल टेबल : टॉप लेफ्ट सेल A1 है और नीचे राइट सेल F6 है

1   4   1   2   3   4
d   a   5   6   7   8
f   9   11  1   1   121
a   21  1   12  12  sa
b   a   a   sd  a   sa
324 234 234 23  423 42

मैक्रो

Sub DeselectCell()
    Dim rng As Range
    Dim InputRng As Range
    Dim DeleteRng As Range
    Dim OutRng As Range
    xTitleId = "DeselectCell"
    Set InputRng = Application.Selection
    Set InputRng = Application.InputBox("Range :", xTitleId, InputRng.Address, Type:=8)
    Set DeleteRng = Application.InputBox("Delete Range", xTitleId, Type:=8)
    For Each rng In InputRng
        If Application.Intersect(rng, DeleteRng) Is Nothing Then
            If OutRng Is Nothing Then
                Set OutRng = rng
            Else
                Set OutRng = Application.Union(OutRng, rng)
            End If
        End If
    Next
    OutRng.Select
End Sub

Sub CopyMultipleSelection()
    Dim SelAreas() As Range
    Dim PasteRange As Range
    Dim UpperLeft As Range
    Dim NumAreas As Integer, i As Integer
    Dim TopRow As Long, LeftCol As Integer
    Dim RowOffset As Long, ColOffset As Integer
    Dim NonEmptyCellCount As Integer
' Exit if a range is not selected
    If TypeName(Selection) <> "Range" Then
        MsgBox "Select the range to be copied. A multiple selection is allowed."
        Exit Sub
    End If
' Store the areas as separate Range objects
    NumAreas = Selection.Areas.Count
    ReDim SelAreas(1 To NumAreas)
    For i = 1 To NumAreas
        Set SelAreas(i) = Selection.Areas(i)
    Next
' Determine the upper left cell in the multiple selection
    TopRow = ActiveSheet.Rows.Count
    LeftCol = ActiveSheet.Columns.Count
    For i = 1 To NumAreas
        If SelAreas(i).Row < TopRow Then TopRow = SelAreas(i).Row
        If SelAreas(i).Column < LeftCol Then LeftCol = SelAreas(i).Column
    Next
    Set UpperLeft = Cells(TopRow, LeftCol)
' Get the paste address
    On Error Resume Next
    Set PasteRange = Application.InputBox _
    (Prompt:="Specify the upper left cell for the paste range:", _
    Title:="Copy Mutliple Selection", _
    Type:=8)
    On Error GoTo 0
' Exit if canceled
    If TypeName(PasteRange) <> "Range" Then Exit Sub
' Make sure only the upper left cell is used
    Set PasteRange = PasteRange.Range("A1")
' Check paste range for existing data
    NonEmptyCellCount = 0
    For i = 1 To NumAreas
        RowOffset = SelAreas(i).Row - TopRow
        ColOffset = SelAreas(i).Column - LeftCol
        NonEmptyCellCount = NonEmptyCellCount + _
        Application.CountA(Range(PasteRange.Offset(RowOffset, ColOffset), _
        PasteRange.Offset(RowOffset + SelAreas(i).Rows.Count - 1, _
        ColOffset + SelAreas(i).Columns.Count - 1)))
  Next i
' If paste range is not empty, warn user
  If NonEmptyCellCount <> 0 Then _
        If MsgBox("Overwrite existing data?", vbQuestion + vbYesNo, _
        "Copy Multiple Selection") <> vbYes Then Exit Sub
' Copy and paste each area
  For i = 1 To NumAreas
    RowOffset = SelAreas(i).Row - TopRow
    ColOffset = SelAreas(i).Column - LeftCol
    SelAreas(i).Copy PasteRange.Offset(RowOffset, ColOffset)
  Next i
End Sub

Comments

@ Máté Juhász कम से कम आप कर सकते हैं यदि आप सही उत्तर के लिए मेरी टिप्पणी को हटाने जा रहे हैं तो यह अपवोट है इसलिए मुझे टिप्पणी करने में सक्षम होने के लिए 10 प्रतिष्ठा मिल सकती है।

— जॉर्डनजीएस

वहाँ फिर जाओ :) आपका स्वागत है!

— ejbytes