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

मुझे पता है कि यह बहुत कुछ नहीं है, लेकिन मैं इन अधूरे संस्करणों के साथ फंस गया हूं (दूसरा बिल्कुल भी काम नहीं कर रहा है) ...

Sub conso()
Dim folderpath As String
Dim file As String
Dim i As Long

folderpath = InputBox("Please paste the folder path", "Choose Folder") & "\"
file = Dir(folderpath)

Do While file <> ""
    Workbooks.Open folderpath & file
        ActiveWorkbook.Worksheets(1).Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
        'ActiveSheet.Name = Right(Left(file, Len(file) - 5), Len(Left(file, Len(file) - 5)) - InStr(1, Left(file, Len(file) - 5), "("))
        'ActiveSheet.Name = file
        ActiveSheet.Name = Left(file, InStr(file, ".") - 1)
        Workbooks(file).Close
        
    file = Dir()
Loop

End Sub

दूसरा:

Sub open_and_copy_sheets()

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

Dim my_FileName As Variant
Dim nm As String
Dim nm2 As String
Dim i As Integer

nm = ActiveWorkbook.Name

my_FileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")
If my_FileName <> False Then
    Workbooks.Open Filename:=my_FileName
End If

Workbooks(Workbooks.Count).Activate
nm2 = ActiveWorkbook.Name

For i = 1 To Workbooks(nm2).Worksheets.Count
      Sheets(i).Copy after:=Workbooks(nm).Sheets(Workbooks(nm).Sheets.Count)
Next i

Workbooks(nm2).Close SaveChanges:=False

Workbooks(nm).Activate
Worksheets(1).Activate

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

किसी भी मदद की बहुत सराहना की जाएगी! मैं वीबीए में इतना अच्छा नहीं हूं इसलिए किसी भी स्पष्टीकरण का भी स्वागत किया जाएगा :)

0
Robert Cenusa 22 अप्रैल 2021, 18:51
यहां देखें, इस प्रकार की चीज़ों के बारे में कुछ प्रश्न पहले से ही कोड के साथ मौजूद हैं।
 – 
Solar Mike
22 अप्रैल 2021, 21:59

1 उत्तर

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

यदि आप चाहते हैं कि फ़ंक्शन आपकी PersonalWorkbook में उपलब्ध हो, तो VBA संपादक के माध्यम से अपने Personal.XLSB के नीचे एक "मॉड्यूल" बनाएं (स्क्रीन ग्रैब देखें)। मैंने आपका कोड थोड़ा तय कर दिया है:

Option Explicit

Sub test()

    Dim destinationFile As Variant
    Dim sourceWbk As Workbook
    Dim destinationWbk As Workbook
    Dim sheet As Worksheet
    Dim index As Integer
    
    Application.ScreenUpdating = False
    Set sourceWbk = ActiveWorkbook
    
    destinationFile = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")
    
    If destinationFile <> False Then
        
        Workbooks.Open fileName:=destinationFile
        Set destinationWbk = ActiveWorkbook
        
        For Each sheet In sourceWbk.Sheets
          
          sheet.Copy Before:=destinationWbk.Sheets(index)
          index = index + 1
        
        Next sheet
        
        MsgBox (index & " sheets copied")
        
    Else
    
        MsgBox ("No file selected. Action aborted.")
        
    End If
    
    Set sheet = Nothing
    Set sourceWbk = Nothing
    Set destinationWbk = Nothing
    Application.ScreenUpdating = True
    
End Sub

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

यहाँ अद्यतन एक पूर्ण समाधान है:

आप जो चाहते हैं उसे पाने के लिए आपको इसे अलग-अलग हिस्सों में तोड़ना होगा।

चरण 1 - उपयोगकर्ता से पूछें कि क्या वे शीट को एक फ़ाइल या गुणकों में कॉपी कर रहे हैं:

    Public Function MasterCopy()

    Dim choice As Variant
    
    choice = InputBox("Enter S or M:", "Select whether to copy to a single or multiple sheets")
    
    Select Case UCase(choice)
        
        Case "S"
        
            Call FncSingleFileCopy
        
        Case "M"
        
            Call FncMultiFileCopy
            
        Case Else
        
            MsgBox ("Cancelled.")
            
    End Select
    
    
End Function

चरण 2: दो फ़ंक्शन जोड़ें, एक गुणकों की प्रतिलिपि बनाने के लिए और एक एकल के लिए:

    Private Function FncMultiFileCopy()

    Dim destinationFile As Variant
    Dim sourceWbk As Workbook
    Dim folderPath As String
    Dim copied As Integer
    
    Set sourceWbk = ActiveWorkbook
    
    folderPath = InputBox("Please paste the folder path", "Choose Folder")
    
    If (folderPath) <> "" Then
        
        folderPath = folderPath & "\"
        destinationFile = Dir(folderPath)

        Do While destinationFile <> ""
        
            If InStr(destinationFile, ".xls") > 1 Then
        
                Call FncCopySheets(sourceWbk, folderPath & destinationFile)
        
            End If
        
            destinationFile = Dir()
    
        Loop
        
        MsgBox ("Finished.")
        
    Else
    
        MsgBox ("Cancelled.")
        
    End If
    
    Set sourceWbk = Nothing
    
End Function

Private Function FncSingleFileCopy()

    Dim destinationFile As Variant
    Dim sourceWbk As Workbook
    Dim copied As Integer
    
    Set sourceWbk = ActiveWorkbook
    
    destinationFile = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")
    
    If destinationFile <> False Then
        
        copied = FncCopySheets(sourceWbk, destinationFile)
        
        MsgBox (copied & " sheets copied")
        
    Else
    
        MsgBox ("No file selected. Action aborted.")
        
    End If
    
    Set sourceWbk = Nothing
    
End Function

चरण 3: अंत में, एक फ़ंक्शन जो शीट की प्रतिलिपि बनाने के लिए एक स्रोत कार्यपुस्तिका और गंतव्य फ़ाइल लेता है, जिसे पिछले दो कार्यों में से किसी एक से बुलाया जा सकता है:

    Private Function FncCopySheets(sourceWbk As Workbook, destinationFile As Variant) As Integer
    
    Dim destinationWbk As Workbook
    Dim sht As Worksheet
    Dim shtsCopied As Integer
    
    Application.ScreenUpdating = False
    
    Set destinationWbk = Workbooks.Open(destinationFile)
    
    For Each sht In sourceWbk.Sheets
          
        sht.Copy Before:=destinationWbk.Sheets(1)
        shtsCopied = shtsCopied + 1
        
    Next sht
        
    destinationWbk.Close (True)
    
    Application.ScreenUpdating = True
    
    FncCopySheets = shtsCopied
    
    Set destinationWbk = Nothing
    
End Function
0
Davy C 23 अप्रैल 2021, 13:16
0 आपके उत्तर के लिए धन्यवाद, मैंने आपका कोड चलाया है और यह मुझे 'शीट.कॉपी बिफोर:=destinationWbk.Sheets(index)' पर एक त्रुटि देता है। साथ ही, जैसा कि मैंने देखा, आपका कोड एकाधिक शीट वाली एकाधिक कार्यपुस्तिकाओं के लिए लागू नहीं होता है।
 – 
Robert Cenusa
23 अप्रैल 2021, 09:03
तो मूल रूप से मुझे अपने पहले कोड में 'फ़ोल्डरपथ = इनपुटबॉक्स ("कृपया फ़ोल्डर पथ पेस्ट करें", "फ़ोल्डर चुनें") और "" फ़ाइल = डीआईआर (फ़ोल्डरपाथ) 'को' application.getopenfilename (बहुविकल्पी: = सत्य)' से बदलने की आवश्यकता है। लेकिन फिर मुझे नहीं पता कि 'वर्कबुक्स। ओपन फोल्डरपाथ और फाइल एक्टिववर्कबुक। वर्कशीट्स (1) को कैसे लागू करें। इसके बाद कॉपी करें: = यह वर्कबुक। वर्कशीट्स (यह वर्कबुक। वर्कशीट्स। काउंट) एक्टिवशीट।नाम = लेफ्ट (फाइल, इनस्ट्र (फाइल,) "।") - 1) वर्कबुक (फाइल)। क्लोज' (जो एक शीट के साथ एक वर्कबुक के लिए ठीक काम करता है) चयनित प्रत्येक वर्कबुक और उसकी शीट के लिए।
 – 
Robert Cenusa
23 अप्रैल 2021, 09:03
मैंने अपना जवाब अपडेट कर लिया है। पीएस - मुझे यह बताने का कोई मतलब नहीं है कि आपको एक त्रुटि मिलती है और मुझे यह नहीं बताते कि त्रुटि क्या है!
 – 
Davy C
23 अप्रैल 2021, 13:17