Question

I have many excel files in a folder.

I wanted a macro to iterate through each file and copy sheet named final cost and make a sheet with name of source file in destination file.

Like there are three files A, B, C each having a sheet named “final cost

The new file will have three sheets named

• A,
• B,
• C

The edited code looks like

Sub RunCodeOnAllXLSFiles()
    Dim lCount As Long
    Dim wbResults As Workbook
    Dim wbCodeBook As Workbook

    'Application.ScreenUpdating = False
    'Application.DisplayAlerts = False
    'Application.EnableEvents = False

    'On Error Resume Next

    'Set wbCodeBook = ThisWorkbook

    Dim FilePath    As String, fName As String
    Dim aWB As Workbook, sWB As Workbook

    Set aWB = ActiveWorkbook
    FilePath = "D:\binny\" 'change to suit
    fName = Dir(FilePath & "*.xls")

    Do While fName <> ""
        If fName <> aWB.Name Then
            Set sWB = Workbooks.Open(FileName:=FilePath & fName, UpdateLinks:=0)
            sWB.Worksheets("Final Cost").Range("A1:Z6666").Copy
            sWB.Close False
            Sheets.Add.Name = fName
            Worksheets(fName).Range("D1").Select
            ActiveSheet.PasteSpecial Format:= _
            "Microsoft Word 8.0 Document Object"
        End If
        fName = Dir
    Loop
    Set sWB = Nothing: Set aWB = Nothing


               'Application.ScreenUpdating = True
    'Application.DisplayAlerts = True
    'Application.EnableEvents = True
End Sub

The things now to do are:

1. preserve formatting and cell width
2. I can’t get Paste Special to work
3. Delete worksheet with same name if exists

Answer 1

You have got the most part figured out. Here is what I recommend.

Set a name for 1 main worksheet in the file from where the macro is run so that you can delete all sheets except that one sheet in 1 go. Let’s say that the main sheet is “MainSheet”

For example

Sub Sample()
    Dim ws As Worksheet

    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> "MainSheet" Then
            Application.DisplayAlerts = False
            ws.Delete
            Application.DisplayAlerts = True
        End If
    Next ws
End Sub

Now you can add this code to the beginning of your code. I have modified your code. All I am doing in your code is after the sheet is created, simply delete the columns after Z.

See this (UNTESTED)

Sub test()
    Dim FilePath As String, fName As String
    Dim aWB As Workbook, sWB As Workbook
    Dim ws As Worksheet
    Dim ColName As String

    Set aWB = ThisWorkbook

    '~~> Delete sheets
    For Each ws In aWB.Sheets
        If ws.Name <> "MainSheet" Then
            Application.DisplayAlerts = False
            ws.Delete
            Application.DisplayAlerts = True
        End If
    Next ws

    FilePath = "D:\binny\" '<~~ Change to suit

    fName = Dir(FilePath & "*.xls")

    Do While fName <> ""
        If fName <> aWB.Name Then
            Set sWB = Workbooks.Open(Filename:=FilePath & fName, UpdateLinks:=0)
            sWB.Sheets("Final Cost").Move after:=aWB.Sheets(aWB.Sheets.Count)
            sWB.Close False
            '~~> The sheet is copied, simply delete the columns after Z
            With aWB.Sheets(aWB.Sheets.Count)
                .Name = fName
                .Cells.Copy
                .Cells.PasteSpecial xlPasteValues
                '~~> Get the last column Name
                ColName = Split(.Cells(, .Columns.Count).Address, "$")(1)
                .Columns("AA:" & ColName).Delete
            End With
        End If
        fName = Dir
    Loop
    Set sWB = Nothing: Set aWB = Nothing
End Sub

Give it a try and if you get any errors, let me know which line and I will rectify it.