Move worksheet to a workbook with same name

[Stella502]

I have 4 workbooks with several worksheets (the names of the worksheet range from 0801 to 0899, some also have 081A, 082B etc). Not all worksheets are in each workbook. These workbooks are named AvailFunds, Detailed AP Transactions, JVTransactions & Encumbrance.
I want to have several workbooks with the workbooks names in the range of from 0801 to 0899, some also have 081A, 082B etc.

Could someone please assist with VBA code. I would like to do a loop to move all the worksheets in workbooks are named AvailFunds, Detailed AP Transactions, JVTransactions & Encumbrance. to the workbook with the same name and rename the worksheet to the workbook name. I would like to move the entire worksheet so that it has the formating and page setup as it does in the AvailFunds, Detailed AP Transactions, JVTransactions & Encumbrance. worksheets.

Hope that explains it well enough. Any assistance would be much appreciated.

This is what I have so far but because there are so many worksheets (maybe 40, and not all 08#s exist in each workbook ) doing the code for one would be extremely long and generate errors.

Sub RCWorkbk()
'
' RCWorkbk Macro
'


   
' Open workbooks
    Workbooks.Open filename:= _
        "P:\Budget\Reports\Expenditure Reports\Current\AvailFunds.xlsx"
    Workbooks.Open filename:= _
        "P:\Budget\Reports\Expenditure Reports\Current\Detailed AP Transactions.xlsx"
    Workbooks.Open filename:= _
        "P:\Budget\Reports\Expenditure Reports\Current\JVTransactions.xlsx"
    Workbooks.Open filename:= _
        "P:\Budget\Reports\Expenditure Reports\Current\Encumbrance.xlsx"
          
'Copy all of the 0801 to New workbook as RC Name
' First Move 0801 AvailBal
    Windows("AvailFunds.xlsx").Activate
    On Error Resume Next
    If (Worksheets("0801").Name <> "") Then
    Sheets("0801").Move Before:=Workbooks("0801.xlsx").Sheets(1)
    Sheets("0801").Name = "Available Funds"
    ActiveWorkbook.SaveAs filename:= _
        "P:\Budget\Reports\Expenditure Reports\current\0801.xlsx", FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
    End If
' 2nd Move 0801 Expenditure Transactions
    Windows("Detailed AP Transactions.xlsx").Activate
    If (Worksheets("0801").Name <> "") Then
        Sheets("0801").Move After:=Workbooks("0801.xlsx").Sheets(1)
        Sheets("0801").Name = "Expenditure Transactions"
    End If
' 3rd Move 0801 JV Transactions
    Windows("JVTransactions.xlsx").Activate
    If (Worksheets("0801").Name <> "") Then
        Sheets("0801").Move After:=Workbooks("0801.xlsx").Sheets(2)
        Sheets("0801").Name = "JV Transactions"
    End If
' 4th Move 0801 Encumbrances
    Windows("Encumbrance.xlsx").Activate
    If (Worksheets("0801").Name <> "") Then
        Sheets("0801").Move After:=Workbooks("0801.xlsx").Sheets(3)
        Sheets("0801").Name = "Encumbrance"
    End If
    ActiveWorkbook.Save
    ActiveWorkbook.Close


'Copy all of the 0811 to New workbook as RC Name
' First Move 0811 AvailBal
    Windows("Available Funds Rep.xlsx").Activate
    Sheets("0811").Select
    Sheets("0811").Move
    Sheets("0811").Name = "Available Balance"
    ActiveWorkbook.SaveAs filename:= _
        "P:\Budget\Reports\Expenditure Reports\Expenditures\current\0811.xlsx", FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
' 2nd Move 0811 Expenditure Transactions
    Windows("Expenditure Transactions.xlsx").Activate
    Sheets("0811").Select
    Sheets("0811").Move After:=Workbooks("0811.xlsx").Sheets(1)
    Sheets("0811").Name = "Expenditure Transactions"
' 3rd Move 0811 JV Transactions
    Windows("JVTransactions.xlsx").Activate
    Sheets("0811").Select
    Sheets("0811").Move Before:=Workbooks("0811.xlsx").Sheets(2)
    Sheets("0811").Name = "JV Transactions"
' 4th Move 0811 Encumbrances
    Windows("Encumbrance.xlsx").Activate
    Sheets("0811").Select
    Sheets("0811").Move After:=Workbooks("0811.xlsx").Sheets(3)
    Sheets("0811").Name = "Encumbrance"
    ActiveWorkbook.Save
    ActiveWorkbook.Close
End Sub

 

[DanteAmor]

Put the following macro in a new book.
The macro will create the books, 0801, 0811, 08 ##, with the corresponding sheets of each book (AvailFunds, Detailed AP Transactions, JVTransactions & Encumbrance)

Sub Move_Sheets()
'
' RCWorkbk Macro
'
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    '
    Set l1 = ThisWorkbook
    Set h1 = l1.Sheets(1)
    h1.Cells.Clear
    '
    ruta = "P:\Budget\Reports\Expenditure Reports\Current\"
    workbs = Array("AvailFunds.xlsx", _
                   "Detailed AP Transactions.xlsx", _
                   "JVTransactions.xlsx", _
                   "Encumbrance.xlsx")
' Open workbooks
    i = 1
    For n = LBound(workbs) To UBound(workbs)
        Set l2 = Workbooks.Open(Filename:=ruta & workbs(n))
        For Each hoja In l2.Sheets
            h1.Cells(i, "A").Value = l2.Name
            h1.Cells(i, "B").Value = "'" & hoja.Name
            i = i + 1
        Next
    Next
    '
    u = h1.Range("A" & Rows.Count).End(xlUp).Row
    With h1.Sort
        .SortFields.Clear
        .SortFields.Add Key:=h1.Range("B1:B" & u), SortOn:=xlSortOnValues, Order:=xlAscending
        .SetRange h1.Range("A1:B" & u): .Header = xlGuess: .MatchCase = False
        .Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
    End With
    '
    h1.Columns("B:B").Copy h1.Range("D1")
    h1.Range("D1:D" & u).RemoveDuplicates Columns:=1, Header:=xlNo
    '
    For i = 1 To h1.Range("D" & Rows.Count).End(xlUp).Row
        Set l3 = Workbooks.Add
        valor = h1.Cells(i, "D").Value
        l3.SaveAs Filename:=ruta & valor & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        Set r = h1.Columns("B")
        Set b = r.Find(valor, LookAt:=xlWhole)
        If Not b Is Nothing Then
            celda = b.Address
            Do
                'detalle
                libro = h1.Cells(b.Row, "A").Value
                hoja = h1.Cells(b.Row, "B").Value
                namehoja = Left(libro, Len(libro) - 5)
                Workbooks(libro).Sheets(hoja).Move Before:=l3.Sheets(1)
                l3.Sheets(1).Name = namehoja
                Set b = r.FindNext(b)
            Loop While Not b Is Nothing And b.Address <> celda
        End If
        l3.Close True
        Set l3 = Nothing
    Next
    '
    h1.Cells.Clear
    Application.ScreenUpdating = True
    MsgBox "End"
End Sub

Regards Dante Amor

 

[Stella502]

Dante,
I tried your code and it work excellent.
Thank you, Thank you, Thank you!!!
You are brilliant!

 

[DanteAmor]

Youre welcome