Excelmacros来整合数据

我有一个文件夹中的许多Excel文件。

我想要一个macros遍历每个文件并复制名为final cost的工作表，并在目标文件中创build一个名为源文件的工作表。

就像有三个文件A，B，C，每个文件都有一张名为“最终成本”的表

新文件将有三张名为

• 一个，
• B，
• C

编辑的代码看起来像

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 

现在要做的事情是：

1. 保留格式和单元格宽度
2. 我无法使用Paste Special工作
3. 如果存在，删除具有相同名称的工作表

Answer 1

你已经得到了大部分的想法。 这是我推荐的。

在运行macros的文件中为一个主工作表设置一个名称，这样您就可以删除所有工作表，除了一个工作表中的一个工作表。 假设主表是“MainSheet”

例如

 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 

现在，您可以将此代码添加到代码的开头。 我修改了你的代码。 我在你的代码中所做的是在创build表单之后，只需删除Z之后的列。

看到这个（ 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 

试一试，如果你有任何错误，让我知道哪一行，我会纠正它。