创build新的.xlsx文件并使用Excel VBA写入

我无法find适合我的问题的现有线程，现在我陷入困境并寻求帮助;）

我想完成的是：几个填充了内容的.xlsx表格在同一个文件夹中，我想从每个文件中select相同的两个单元格的内容，并将其保存到一个新创build的名为“Summary.xlsx”的.xslx文件中。

我的makro正确读出单元格的内容并保存Summary.xlsx。 然而，它看起来像文件已损坏，因为当我试图打开它时，Excel将显示我只是一个空白页（甚至不是一张纸）。

使用断点监视文件，标题得到正确写入：但是，当我尝试在do-while循环中写入其他文件的内容时，Summary.xlsx中的表开始消失。

附加信息：我使用模块中的播放button从其他文件的同一目录中的额外makro文件启动makro。

这是我的代码。

警告：我是新来的VBA，显然:)

Sub MergeMakro() Dim directory As String, fileName As String, otherWorkbook As Workbook, sumFileName As String, sumFilePath As String, i As Integer thisFileName = "MergeMakro.xlsm" sumFileName = "Summary.xlsx" sumFilePath = ThisWorkbook.Path & "\" & sumFileName ' If sum file already exists, delete it If Dir(sumFilePath) <> "" Then Kill (sumFilePath) End If ' create new sum file Set sumWorkbook = Workbooks.Add ActiveWorkbook.SaveAs fileName:=sumFilePath Set sumSheet = sumWorkbook.ActiveSheet ' search in the file's directory directory = "R:\ExcelStuff\Auswertungen\" ' headlines -> are written properly sumSheet.Range("A1") = "Materialnummern" sumSheet.Range("B1") = "Bezeichnung" sumSheet.Range("C1") = "Gesamtkosten" ' start at line 2 i = 2 fileName = Dir(directory & "*.xls") Do While fileName <> "" If fileName <> thisFileName And fileName <> sumFileName Then Set otherWorkbook = Workbooks.Open(directory & fileName) ' do not show windows If Not (ActiveWorkbook Is Nothing) Then ActiveWindow.Visible = False End If ' remove last 5 chars of string (.xlsx) fileName = Left(fileName, Len(fileName) - 5) ' do not try to open the makro-file itself Set otherSheet = otherWorkbook.Sheets(fileName) ' write data into file -> here the file starts to get corrupted sumSheet.Range("A" & i) = fileName sumSheet.Range("B" & i) = otherSheet.Range("C4") sumSheet.Range("C" & i) = otherSheet.Range("G4") i = i + 1 otherWorkbook.Close End If ' get the next file fileName = Dir() Loop Workbooks(sumFileName).Save Workbooks(sumFileName).Close End Sub 

提前致谢！