Question

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

Answer 1

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

Answer 2

这应该可以解决您的问题。我正在使用for循环遍历所有工作表：

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

如何基于两个条件将工作簿中的工作表移动到其他两个打开的（新创建的）工作簿中，请参见下面的代码？

2 个答案: