Help creating a macro to open another file, rename sheet and copu each one as a new workbook

0

I need to create a macro that open a dailog to choose an excel file, open that excel file, rename each of its sheet by copying the cell B4 of the chosen file and lastly create a new workbook with each one of the sheets.

I have two separate module one that choose and open the file and a second module that rename the sheets and create new worksheets but i dont know how to put both together.

HELP PLEASE

MODULE ONE = CHOOSE AND OPEN FILE

Sub Select_File_Or_Files_Windows()
    Dim SaveDriveDir As String
    Dim MyPath As String
    Dim Fname As Variant
    Dim N As Long
    Dim FnameInLoop As String
    Dim mybook As Workbook
    ' Save the current directory.
    SaveDriveDir = CurDir
    ' Set the path to the folder that you want to open.
    MyPath = Application.DefaultFilePath
    ' You can also use a fixed path.
    'MyPath = "C:\Users\Ron de Bruin\Test"
    ' Change drive/directory to MyPath.
    ChDrive MyPath
    ChDir MyPath
    ' Open GetOpenFilename with the file filters.
    Fname = Application.GetOpenFilename( _
            FileFilter:="Excel 97-2003 Files (*.xls), *.xls", _
            Title:="Select a file or files", _
            MultiSelect:=True)
    ' Perform some action with the files you selected.
    If IsArray(Fname) Then
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With
        For N = LBound(Fname) To UBound(Fname)
            ' Get only the file name and test to see if it is open.
            FnameInLoop = Right(Fname(N), Len(Fname(N)) - InStrRev(Fname(N), Application.PathSeparator, , 1))
            If bIsBookOpen(FnameInLoop) = False Then
                Set mybook = Nothing
                On Error Resume Next
                Set mybook = Workbooks.Open(Fname(N))
                On Error GoTo 0
                If Not mybook Is Nothing Then
                    MsgBox "You opened this file : " & Fname(N) & vbNewLine & _
                           "And after you press OK, it will be closed" & vbNewLine & _
                           "without saving. You can replace this line with your own code."
                    mybook.Close SaveChanges:=False
                End If
            Else
                MsgBox "We skipped this file : " & Fname(N) & " because it is already open."
            End If
        Next N
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
    End If
    ' Change drive/directory back to SaveDriveDir.
    ChDrive SaveDriveDir
    ChDir SaveDriveDir
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Contributed by Rob Bovey
    On Error Resume Next
    bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function

MODULE 2 -  RENAME SHEET AND CREATE NEW WORKBOOK

(This macro is done so it work from the same book, but it has to modified to be execute from the first book over the chosen new file)

Sub CreatePOFiles()
'UpdatebyTony
For x = 1 To Sheets.Count
If Worksheets(x).Range("B4").Value <> "" Then
Sheets(x).Name = Worksheets(x).Range("B4").Value
End If
Next
Dim xPath As String
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
    xWs.Copy
    Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xls"
    Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

I need HELP HELP HELP i am a neophit not programming skills

Answer
Discuss

Discussion

Please put CODE tags around your code. To do that, edit your post, select your code and click the CODE button.

Also, I will look at this over the weekend but it shouldn't be too difficult to fix.
don (rep: 1492) Aug 11, '16 at 11:34 pm
Add to Discussion

Answers

0

Try this macro:

Sub Select_File_Or_Files_Windows()
    Dim SaveDriveDir As String
    Dim MyPath As String
    Dim Fname As Variant
    Dim N As Long
    Dim FnameInLoop As String
    Dim mybook As Workbook
    ' Save the current directory.
    SaveDriveDir = CurDir
    ' Set the path to the folder that you want to open.
    MyPath = Application.DefaultFilePath
    ' You can also use a fixed path.
    'MyPath = "C:\Users\Ron de Bruin\Test"
    ' Change drive/directory to MyPath.
    ChDrive MyPath
    ChDir MyPath
    ' Open GetOpenFilename with the file filters.
    Fname = Application.GetOpenFilename( _
            FileFilter:="Excel 97-2003 Files (*.xls), *.xls", _
            Title:="Select a file or files", _
            MultiSelect:=True)
    ' Perform some action with the files you selected.
    If IsArray(Fname) Then
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With
        For N = LBound(Fname) To UBound(Fname)
            ' Get only the file name and test to see if it is open.
            FnameInLoop = Right(Fname(N), Len(Fname(N)) - InStrRev(Fname(N), Application.PathSeparator, , 1))
            If bIsBookOpen(FnameInLoop) = False Then
                Set mybook = Nothing
                On Error Resume Next
                Set mybook = Workbooks.Open(Fname(N))
                On Error GoTo 0
                If Not mybook Is Nothing Then


                    For x = 1 To mybook.Sheets.Count
                    If mybook.Worksheets(x).Range("B4").Value <> "" Then
                    mybook.Sheets(x).Name = mybook.Worksheets(x).Range("B4").Value
                    End If
                    Next
                    Dim xPath As String
                    xPath = Application.ActiveWorkbook.Path
                    Application.ScreenUpdating = False
                    Application.DisplayAlerts = False
                    For Each xWs In mybook.ThisWorkbook.Sheets
                        xWs.Copy
                        Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xls"
                        Application.ActiveWorkbook.Close False
                    Next
                    Application.DisplayAlerts = True
                    Application.ScreenUpdating = True


                    mybook.Close SaveChanges:=False
                End If
            Else
                MsgBox "We skipped this file : " & Fname(N) & " because it is already open."
            End If
        Next N
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
    End If
    ' Change drive/directory back to SaveDriveDir.
    ChDrive SaveDriveDir
    ChDir SaveDriveDir
End Sub

It is a combined version of the two macros. I didn't include the Function "Function bIsBookOpen(ByRef szBookName As String) As Boolean" so jut make sure that that is still in your module.

Also, make sure to try this on sample data first. (I haven't been able to test it.)

Discuss

Answer the Question

You must create an account to use the forum. Create an Account or Login