मैं एक वीबीए बनाने की कोशिश कर रहा हूं जो कई कार्यपुस्तिकाएं खोलेगा (केवल एक भी), उनकी सभी शीट्स को किसी अन्य कार्यपुस्तिका में कॉपी करें। मैं अपने कोड को सीधे व्यक्तिगत वर्कबुक से कार्यात्मक बनाना चाहता हूं ताकि मैं इसे किसी भी नई कार्यपुस्तिका में उपयोग कर सकूं जो मैं चाहता हूं।
मुझे पता है कि यह बहुत कुछ नहीं है, लेकिन मैं इन अधूरे संस्करणों के साथ फंस गया हूं (दूसरा बिल्कुल भी काम नहीं कर रहा है) ...
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
किसी भी मदद की बहुत सराहना की जाएगी! मैं वीबीए में इतना अच्छा नहीं हूं इसलिए किसी भी स्पष्टीकरण का भी स्वागत किया जाएगा :)
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