Sub transfersheets()
Dim originalwb As String, ws As Worksheet, wb1name As String, wb2name As String

originalwb = ThisWorkbook.Name

wb1name = Workbooks(originalwb).Worksheets("source").Range("B2").Value & " " & "MD" & " " & "&" & " " & "Prime" & " " & "Rdg. Sht." & " " & "&" & " " & "Direct." & " " & UCase(Format(Date, "mmmm yyyy")) & ".xlsx"
wb2name = Workbooks(originalwb).Worksheets("source").Range("B2").Value & " " & "Non" & " " & "MD" & " " & "Rdg. Sht." & " " & "&" & " " & "Direct." & " " & UCase(Format(Date, "mmmm yyyy ")) & ".xlsx"

'Workbooks(originalwb).Activate
Application.ScreenUpdating = False
For Each Worksheet In Workbooks(originalwb).Worksheets

'If Len(ws.Name) > 6 Then

    If Len(Worksheet.Name) > 6 And Worksheet.Name = "NMD*" Then
     Workbooks(originalwb).ws.Move Before:=Workbooks(wb2name).Worksheets(Sheets.Count)


     ElseIf Len(Worksheet.Name) > 6 And Worksheet.Name = "PRIME*" Then
     Workbooks(originalwb).ws.Move Before:=Workbooks(wb1name).Worksheets(Sheets.Count)

     ElseIf Len(Worksheet.Name) > 6 And Worksheet.Name = "MD*" Then
     Workbooks(originalwb).ws.Move Before:=Workbooks(wb1name).Worksheets(Sheets.Count)
    End If
'End If
Next
    Workbooks(wb1name).Save
    Workbooks(wb1name).Close


    Workbooks(wb2name).Save
    Workbooks(wb2name).Close

    Workbooks(originalwb).Worksheets("source").Range("AA:AG").ClearContents

    MsgBox "The Reading Sheets & Direct Customers' Lists has  Been Successfully  Prepared."

    Application.ScreenUpdating = True
End Sub
-3
ju'blu' 18 जुलाई 2018, 17:36
आपके पास पहले से ही कोड है जो कार्यपत्रकों को एक कार्यपुस्तिका से दूसरी कार्यपुस्तिका में ले जाता है। क्या आपको त्रुटि मिल रही है? आप अपने प्रश्नों को थोड़ा बेहतर प्रारूपित करना चाह सकते हैं।
 – 
Hasib_Ibradzic
18 जुलाई 2018, 17:50
हां । यह लाइन से एक त्रुटि लौटाता रहता है - वर्कबुक (ओरिजिनलडब्ल्यूबी)।
 – 
ju'blu'
18 जुलाई 2018, 18:00

2 जवाब

Dim wbTarget

For Each ws In Workbooks(originalwb).Worksheets

    If Len(ws.Name) > 6 Then

        If ws.Name Like "NMD*" Then
            Set wbTarget = Workbooks(wb2name)
        ElseIf ws.Name Like "PRIME*" Or ws.Name Like "MD*" Then
            Set wbTarget = Workbooks(wb1name)
        End If
        If Not wbTarget Is Nothing Then
            ws.Move Before:=wbTarget.Worksheets(wbTarget.Sheets.Count)
            Set wbTarget = Nothing
        End If       
    End If
Next
0
Tim Williams 18 जुलाई 2018, 18:09
धन्यवाद। यह अभी भी चादरों को अनुरोधित कार्यपुस्तिकाओं में नहीं ले गया।
 – 
ju'blu'
18 जुलाई 2018, 18:55
ठीक - यह करता है यह क्या करता है? कोई त्रुटि - कुछ भी? क्या आपकी वर्कशीट का शाब्दिक नाम "MD*" आदि है, या आपका मतलब "MD से शुरू होता है"?
 – 
Tim Williams
18 जुलाई 2018, 19:24
वे एमडी, प्राइम एनएमडी से शुरू करते हैं।
 – 
ju'blu'
18 जुलाई 2018, 20:14
धन्यवाद। अभी भी त्रुटि दिखाता है। "ऑब्जेक्ट वैरिएबल या ब्लॉक वैरिएबल सेट नहीं है" लाइन पर रनटाइम एरर 91 - सेट wbTarget = वर्कबुक (wb2name)
 – 
ju'blu'
18 जुलाई 2018, 20:46
फिर wb2name नाम की कोई खुली कार्यपुस्तिका नहीं है। क्या आपको इसे खोलने की ज़रूरत थी?
 – 
Tim Williams
18 जुलाई 2018, 20:47

यह आपकी समस्या को ठीक करना चाहिए। मैं सभी कार्यपत्रकों के माध्यम से लूप के लिए लूप का उपयोग कर रहा हूं:

Sub transfersheets()

Dim originalwb As String, ws As Worksheet, wb1name As String, wb2name As String
originalwb = ThisWorkbook.Name

wb1name = Workbooks(originalwb).Worksheets("source").Range("B2").Value & " " & "MD" & " " & "&" & " " & "Prime" & " " & "Rdg. Sht." & " " & "&" & " " & "Direct." & " " & UCase(Format(Date, "mmmm yyyy")) & ".xlsx"
wb2name = Workbooks(originalwb).Worksheets("source").Range("B2").Value & " " & "Non" & " " & "MD" & " " & "Rdg. Sht." & " " & "&" & " " & "Direct." & " " & UCase(Format(Date, "mmmm yyyy ")) & ".xlsx"

'Workbooks(originalwb).Activate
Application.ScreenUpdating = False
For i = 1 To Workbooks(originalwb).Worksheets.Count

    If Len(Worksheet.Name) > 6 And Worksheet.Name = "NMD*" Then
     Workbooks(originalwb).Sheets(i).Move Before:=Workbooks(wb2name).Worksheets(Sheets.Count)


     ElseIf Len(Worksheet.Name) > 6 And Worksheet.Name = "PRIME*" Then
     Workbooks(originalwb).Sheets(i).Move Before:=Workbooks(wb1name).Worksheets(Sheets.Count)

     ElseIf Len(Worksheet.Name) > 6 And Worksheet.Name = "MD*" Then
     Workbooks(originalwb).Sheets(i).Move Before:=Workbooks(wb1name).Worksheets(Sheets.Count)
    End If
'End If
Next i
    Workbooks(wb1name).Save
    Workbooks(wb1name).Close


    Workbooks(wb2name).Save
    Workbooks(wb2name).Close

    Workbooks(originalwb).Worksheets("source").Range("AA:AG").ClearContents

    MsgBox "The Reading Sheets & Direct Customers' Lists has  Been Successfully  Prepared."

    Application.ScreenUpdating = True
End Sub
0
Hasib_Ibradzic 18 जुलाई 2018, 18:15
धन्यवाद। अभी भी त्रुटि दिखाता है। "ऑब्जेक्ट वैरिएबल या ब्लॉक वैरिएबल सेट नहीं है" रनटाइम त्रुटि 91.
 – 
ju'blu'
18 जुलाई 2018, 19:07
क्या यह अभी भी आपको उसी लाइन पर वह त्रुटि दे रहा है?
 – 
Hasib_Ibradzic
18 जुलाई 2018, 19:27
ओह, और क्या आपकी अन्य कार्यपुस्तिकाएँ खुली हैं??? यदि वे वास्तव में खुले नहीं हैं, तो आपको या तो उन्हें चालू रहने के दौरान खुला छोड़ना होगा या लूप शुरू होने से पहले कार्यपुस्तिकाओं को खोलने के लिए कोड जोड़ना होगा।
 – 
Hasib_Ibradzic
18 जुलाई 2018, 19:30