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

VANCOUVER_RON

New Member
Joined
Apr 23, 2019
Messages
2
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?
:confused::confused::confused:
 

Some videos you may like

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).

alansidman

Well-known Member
Joined
Feb 26, 2007
Messages
5,419
Office Version
2019
Platform
Windows
Here is a code I use regularly
Code:
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

New Member
Joined
Apr 23, 2019
Messages
2
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

Well-known Member
Joined
Feb 26, 2007
Messages
5,419
Office Version
2019
Platform
Windows
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.


Code:
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,095,372
Messages
5,444,076
Members
405,265
Latest member
Iram

This Week's Hot Topics

Top