VBA to copy/paste formatting from open XLSX file to many closed XLSX files

[VANCOUVER_RON]

I have an open xlsx file with a page that has formatting that I want to copy/paste (formatting only) into a number of other single-page xlsx files in the same folder. How can I do this using VBA?

 

[alansidman]

Here is a code I use regularly

Sub MoveFromSourceToTarget()
'Copy Columns A,B,C and D to Master Spreadsheet
    Dim lr As Long
    Dim lrC As Long
    Dim wbTarget As Workbook    'Master
    Dim wbThis As Workbook  'Current Open Workbook
    Dim strName As String    'Name for source sheet/target workbook
    Dim thePath As String  'Path for Master Spreadsheet


    Application.ScreenUpdating = False


    'set the current active workbook
    Set wbThis = ActiveWorkbook
    'set the target workbook name
    strName = "TargetFile"
    'set the path to the Comments Spreadsheet


    thePath = "C:\YourFullPath" 'Make sure that this has all subfolder names included
    'open Master Spreadsheet
    Set wbTarget = Workbooks.Open(thePath & strName & ".xlsm")
    'Activate the Target Workbook
    wbTarget.Activate
    'Find the last row in the target workbook
    lrC = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
    'activate source workbook
    wbThis.Activate
    'find the last row in column A to determine the range to copy
    lr = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
    'clear any thing on the clipboard to mazimize available memory
    Application.CutCopyMode = False
    'Copy Data in Columns A,B,C,D
    wbThis.Sheets("Sheet1").Range("A2:E" & lr).Copy
    'paste the data to the Comments Worksheet
    wbTarget.Sheets("Sheet1").Range("A" & lrC + 1).PasteSpecial
    'Clear the clipboard
    Application.CutCopyMode = False
    wbTarget.Save
    wbTarget.Close
    wbThis.Activate
    Application.ScreenUpdating = True


    'clear memory
    Set wbTarget = Nothing
    Set wbThis = Nothing
    MsgBox "Data Transferred"
End Sub

 

[VANCOUVER_RON]

Thanks for your reply. It appears however that your code takes only a single file ("target file"), the name for which is hard coded. But I have a couple dozen files that I want to copy the formatting to, so i need a looping structure that takes a differently named xlsx file in each loop and, (1) opens it, (2) formats the single sheet within the file, (3) saves it, (4) closes it, and then moves on to the next xlsx file in the folder until there are no more xlsx files to copy formatting to.

 

[alansidman]

Here is some code for looping through a sub-directory. I will need to play with this for your situation as it does not solve your issue but demonstrates only how to loop. You would need to have all the target files in one subfolder and no other files in that folder for a start. Its been awhile for me since I have done that and would need to play and test before I publish.

If in the short term you are willing to use this code, then you could put an Inputbox that asks the user for the name of the file for the target instead of hard coding.

An alternative would be to have the names of all the files to be a target in a separate Open File and loop through those names for the target.

Sub ListAllFile()


    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim ws As Worksheet
    Dim sPath As String
    Dim lrA As Long
    Dim lrB As Long


    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set ws = Worksheets.Add


    'Get the folder object associated with the directory
    sPath = InputBox("What is the full Path to Search?")
    Set objFolder = objFSO.GetFolder(sPath)
    ws.Cells(1, 1).Value = "The files found in " & objFolder.Name & " are:"
    ws.Cells(1, 2).Value = "The files found have modified dates:"
    ws.Cells(1, 3).Value = "The file Size is:"


    'Loop through the Files collection
    For Each objFile In objFolder.Files
    'If objFile.Name Like "*.pdf" Then
        lrA = Range("A" & Rows.Count).End(xlUp).Row
        lrB = Range("B" & Rows.Count).End(xlUp).Row
        ws.Range("A" & lrA + 1).Value = objFile.Name
        ws.Range("B" & lrB + 1).Value = objFile.DateLastModified
        ws.Range("C" & lrB + 1).Value = objFile.Size
    'End If
    Next
    'ws.Cells(2, 1).Delete
    'Clean up!
    Set objFolder = Nothing
    Set objFile = Nothing
    Set objFSO = Nothing


End Sub

Just some thoughts on this.