Macro/VBA to copy a range of data from a worksheet to a new workbook

[oosag23]

Please,can someone help me write a macro.
I have an“A.xls” workbook where I want to open then copy a range of data to “B.xlsx” file.

B.xlsxfile has the same format as a.xls so the data being copied will fit the samerange.

I then want to password protect the new workbook (B.xlsx) and rename andsave it as A.xlsx (same title as “A.xls” file). I need this to repeat for 400files that need this change.

Is it possible to dynamically make this macro to fit for the next files eg. (A-1.xls to B-1.xlsx renamed to A-1.xlsx)

Anyassistance would be much appreciated.

 

[DanteAmor]

Put the next macro in a new file and save it with macros.Put all your files that you want to rename in a folder, then change in the macro "C:\trabajo\libros" by the name of your folder.Change the word "abc" in the macro to the desired password for your files.

Sub Rename_Files()
'
    Dim l2 As Workbook
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.StatusBar = False
    Set l1 = ThisWorkbook
    ruta = "C:\trabajo\libros\"
    '
    Set fso = CreateObject("scripting.filesystemobject")
    Set carpeta = fso.getfolder(ruta)
    num = carpeta.Files.Count
    n = 0
    For Each arch In carpeta.Files
        ext = Right(arch, 3)
        If LCase(ext) = "xls" Then
            n = n + 1
            Application.StatusBar = "Processing file : " & n & " of : " & num
            nombre = Left(arch, Len(arch) - 4)
            Set l2 = Workbooks.Open(Filename:=arch)
            l2.SaveAs Filename:=nombre & ".xlsx", _
                  FileFormat:=xlOpenXMLWorkbook, Password:="abc", CreateBackup:=False
            l2.Close False
        End If
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.StatusBar = False
    MsgBox "Files copied : " & n
End Sub

 

[oosag23]

Can you specify the line of code where the range of data is copiedover from the old workbook to the new workbook? Thank you.

Below is specifically what I need accomplished if it gives more clarity.

1. Start in DirectoryC:/dbasexls ; start with first file 16h1001-JR.xls
2. copy e90:m387 to file: hospitalCR_FY11_Rev0117_macrodisabled.xlsx located in
   C:/dbasexlsx
3. protect the file usingpassword '<bhf>' and</bhf>
4. save the file as16h1001-JR.xlsx (a macro free file)
5. close the file16h1001-JR.xls and
6. repeat with the next filein C:/dbasexls 16h100.xls

 

[DanteAmor]

Could you clarify the following:

1. Start in DirectoryC:/dbasexls ; start with first file 16h1001-JR.xls (The macro will take all the files xls, then put only the files to process )
2. Open the file hospitalCR_FY11_Rev0117_macrodisabled.xlsx correct?
3. copy e90:m387 (Which sheet?) to file: hospitalCR_FY11_Rev0117_macrodisabled.xlsx (In which sheet) located in
   C:/dbasexlsx
4. protect the file usingpassword '<bhf>' (Which password) and</bhf>
5. save the file as16h1001-JR.xlsx (a macro free file) (dont worry if the file is xlsx it will not have macros)
6. close the file16h1001-JR.xls and close new file as16h1001-JR.xlsx
7. open the file hospitalCR_FY11_Rev0117_macrodisabled.xlsx is correct ? and
8. repeat with the next filein C:/dbasexls 16h100.xls

 

[oosag23]

1. Start in DirectoryC:/dbasexls ; start with first file 16h1001-JR.xls (The macro will take all the files xls, then put only the files to process )
2. Open the file hospitalCR_FY11_Rev0117_macrodisabled.xlsx correct? YES
3. copy e90:m387 (16h1001-JR.xls) to file: hospitalCR_FY11_Rev0117_macrodisabled.xlsx (1st sheet, and paste in same range) located in
   C:/dbasexlsx
4. protect the file usingpassword '<bhf>' ("<BHF>") and</bhf>
5. save the file as16h1001-JR.xlsx (a macro free file) (dont worry if the file is xlsx it will not have macros)
6. close the file16h1001-JR.xls and close new file as16h1001-JR.xlsx
7. open the file hospitalCR_FY11_Rev0117_macrodisabled.xlsx is correct ? (THIS 7th step isn't needed)
8. repeat with the next filein C:/dbasexls 16h100.xls

 

[DanteAmor]

Go macro:

Sub Rename_Files()
'
    Dim l1 As Workbook, l2 As Workbook, l3 As Workbook
    Dim h2 As Worksheet, h3 As Worksheet
    Dim ruta As String, arch1 As String, nombre As String
    Dim fso As Object, carpeta As Object
    Dim num As Integer, n As Integer
    Dim arch As String, rango As String
    '
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.StatusBar = False
    '
    Set l1 = ThisWorkbook
    ruta = "C:\dbasexls\"                                   'your folder
    arch1 = "hospitalCR_FY11_Rev0117_macrodisabled.xlsx"    'your file name
    rango = "E90:M387"                                      'your range
    '
    If Right(ruta, 1) <> "\" Then ruta = ruta & "\"
    If Dir(ruta, vbDirectory) = "" Then
        MsgBox "The folder does not exist"
        Exit Sub
    End If
    '
    If Dir(ruta & arch1) = "" Then
        MsgBox "The file does not exist"
        Exit Sub
    End If
    '
    n = 0
    num = 0
    arch = Dir(ruta & "*.xls")
    Do While arch <> ""
        If LCase(Right(arch, 3)) = "xls" Then
            num = num + 1
        End If
        arch = Dir()
    Loop
    '
    arch = Dir(ruta & "*.xls")
    Do While arch <> ""
        If LCase(Right(arch, 3)) = "xls" Then
            n = n + 1
            Application.StatusBar = "Processing file : " & n & " of : " & num
            nombre = Left(arch, Len(arch) - 4)
            '
            Set l2 = Workbooks.Open(Filename:=ruta & arch1)
            Set h2 = l2.Sheets(1)
            Set l3 = Workbooks.Open(Filename:=ruta & arch)
            Set h3 = l3.Sheets(1)
            h3.Range(rango).Copy
            h2.Range("E90").PasteSpecial xlValues
            l2.SaveAs Filename:=ruta & "as" & nombre & ".xlsx", _
                  FileFormat:=xlOpenXMLWorkbook, Password:="", CreateBackup:=False
            l2.Close False
            l3.Close False
            Set h2 = Nothing: Set h3 = Nothing
            Set l2 = Nothing: Set l3 = Nothing
        End If
        arch = Dir()
    Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.StatusBar = False
    Set l1 = Nothing
    Set fso = Nothing: Set carpeta = Nothing
    MsgBox "Files copied : " & n
End Sub

In the lower left corner of excel you can see the progress of the files

Regards

 

[oosag23]

If I want to password protect the worksheet instead of the whole workbook, where should I start?

 

[DanteAmor]

updated Code

Sub Rename_Files()
'
    Dim l1 As Workbook, l2 As Workbook, l3 As Workbook
    Dim h2 As Worksheet, h3 As Worksheet
    Dim ruta As String, arch1 As String, nombre As String
    Dim fso As Object, carpeta As Object
    Dim num As Integer, n As Integer
    Dim arch As String, rango As String
    '
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.StatusBar = False
    '
    Set l1 = ThisWorkbook
    ruta = "C:\dbasexls\"                                   'your folder
    arch1 = "hospitalCR_FY11_Rev0117_macrodisabled.xlsx"    'your file name
    rango = "E90:M387"                                      'your range
    '
    If Right(ruta, 1) <> "\" Then ruta = ruta & "\"
    If Dir(ruta, vbDirectory) = "" Then
        MsgBox "The folder does not exist"
        Exit Sub
    End If
    '
    If Dir(ruta & arch1) = "" Then
        MsgBox "The file does not exist"
        Exit Sub
    End If
    '
    n = 0
    num = 0
    arch = Dir(ruta & "*.xls")
    Do While arch <> ""
        If LCase(Right(arch, 3)) = "xls" Then
            num = num + 1
        End If
        arch = Dir()
    Loop
    '
    arch = Dir(ruta & "*.xls")
    Do While arch <> ""
        If LCase(Right(arch, 3)) = "xls" Then
            n = n + 1
            Application.StatusBar = "Processing file : " & n & " of : " & num
            nombre = Left(arch, Len(arch) - 4)
            '
            Set l2 = Workbooks.Open(Filename:=ruta & arch1)
            Set h2 = l2.Sheets(1)
            Set l3 = Workbooks.Open(Filename:=ruta & arch)
            Set h3 = l3.Sheets(1)
            h3.Range(rango).Copy
            h2.Range("E90").PasteSpecial xlValues
            'set password to protect sheet
            h2.protect "abc"
            '
            l2.SaveAs Filename:=ruta & "as" & nombre & ".xlsx", _
                  FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
            l2.Close False
            l3.Close False
            Set h2 = Nothing: Set h3 = Nothing
            Set l2 = Nothing: Set l3 = Nothing
        End If
        arch = Dir()
    Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.StatusBar = False
    Set l1 = Nothing
    Set fso = Nothing: Set carpeta = Nothing
    MsgBox "Files copied : " & n
End Sub

 

[oosag23]

Thank you! One last small thing. Once I open up the files, the range that was copied over is still highlighted. Is there a way in the macro where I can tell it to go home using the home key or another process. Thanks again for your help.

 

[DanteAmor]

test:

Sub Rename_Files()
'
    Dim l1 As Workbook, l2 As Workbook, l3 As Workbook
    Dim h2 As Worksheet, h3 As Worksheet
    Dim ruta As String, arch1 As String, nombre As String
    Dim fso As Object, carpeta As Object
    Dim num As Integer, n As Integer
    Dim arch As String, rango As String
    '
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.StatusBar = False
    '
    Set l1 = ThisWorkbook
    ruta = "C:\dbasexls\"                                   'your folder
    arch1 = "hospitalCR_FY11_Rev0117_macrodisabled.xlsx"    'your file name
    rango = "E90:M387"                                      'your range
    '
    If Right(ruta, 1) <> "\" Then ruta = ruta & "\"
    If Dir(ruta, vbDirectory) = "" Then
        MsgBox "The folder does not exist"
        Exit Sub
    End If
    '
    If Dir(ruta & arch1) = "" Then
        MsgBox "The file does not exist"
        Exit Sub
    End If
    '
    n = 0
    num = 0
    arch = Dir(ruta & "*.xls")
    Do While arch <> ""
        If LCase(Right(arch, 3)) = "xls" Then
            num = num + 1
        End If
        arch = Dir()
    Loop
    '
    arch = Dir(ruta & "*.xls")
    Do While arch <> ""
        If LCase(Right(arch, 3)) = "xls" Then
            n = n + 1
            Application.StatusBar = "Processing file : " & n & " of : " & num
            nombre = Left(arch, Len(arch) - 4)
            '
            Set l2 = Workbooks.Open(Filename:=ruta & arch1)
            Set h2 = l2.Sheets(1)
            Set l3 = Workbooks.Open(Filename:=ruta & arch)
            Set h3 = l3.Sheets(1)
            h3.Range(rango).Copy
            h2.Range("E90").PasteSpecial xlValues
            l2.activate
            range("A1").Select
            'set password to protect sheet
            h2.protect "abc"
            '
            l2.SaveAs Filename:=ruta & "as" & nombre & ".xlsx", _
                  FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
            l2.Close False
            l3.Close False
            Set h2 = Nothing: Set h3 = Nothing
            Set l2 = Nothing: Set l3 = Nothing
        End If
        arch = Dir()
    Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.StatusBar = False
    Set l1 = Nothing
    Set fso = Nothing: Set carpeta = Nothing
    MsgBox "Files copied : " & n
End Sub