Excel VBA – 从多个工作簿中的数据创build多个文件

我想运行一个macros来从工作表中拉出某些单元格，然后创build一个具有相同名称的文件，但是作为一个csv。 我也想在整个文件夹上运行macros，因为有650个工作簿，但是它们都具有相同的格式，我知道我想要什么单元格。

这是我迄今为止：

Sub converter() Dim oldDoc As Workbook Dim newDoc As Workbook '## Open both workbooks first: Set oldDoc = Workbooks.Open("C:\test.xls") Set newDoc = Workbooks.Open("C:\test_converted.csv") 'Store the value in a variable: impDate = oldDoc.Sheets("Input").Range("D3").Value impTime = oldDoc.Sheets("Input").Range("B6:B101").Value impNB = oldDoc.Sheets("Input").Range("C6:C101").Value impSB = oldDoc.Sheets("Input").Range("D6:D101").Value impEB = oldDoc.Sheets("Input").Range("E6:E101").Value impWB = oldDoc.Sheets("Input").Range("F6:F101").Value impLoc = oldDoc.Sheets("Input").Range("D1").Value 'Use the variable to assign a value to the other file/sheet: newDoc.Sheets("Sheet1").Range("A2:A97").Value = impDate newDoc.Sheets("Sheet1").Range("B2:B97").Value = impTime newDoc.Sheets("Sheet1").Range("C2:C97").Value = impNB newDoc.Sheets("Sheet1").Range("D2:D97").Value = impSB newDoc.Sheets("Sheet1").Range("E2:E97").Value = impEB newDoc.Sheets("Sheet1").Range("F2:F97").Value = impWB newDoc.Sheets("Sheet1").Range("G2:G97").Value = impLoc 'Close oldDoc: oldDoc.Close End Sub 

基本上我希望newDoc从oldDoc中提取文件名并将其保存为csv。 然后，我希望能够一次运行多个文件。

Answer 1

您转换后，两个工作簿都打开工作，并保持不变，以下是转换所有文件的骨架：

 Sub converter() Application.DisplayAlerts = False: Application.ScreenUpdating = False: Application.EnableEvents = False Const fPath As String = "C:\myPath\" ' <---- Your folder path here, dont forget \ Dim oldDoc As Workbook, newDoc As Workbook, fName As String, newName As String fName = Dir(fPath & "*.xl*") Do Until Len(fName) = 0 Set oldDoc = Workbooks.Open(fPath & fName) newName = fPath & Left(fName, InStrRev(fName, ".")) & "csv" Set newDoc = Workbooks.Add '''''''''''''''''''''''''''''''''''''''' ' ' Your conversion code here ' '''''''''''''''''''''''''''''''''''''''' newDoc.SaveAs newName, xlCSV newDoc.Close False oldDoc.Close False fName = Dir Loop Cleanup: If Err.Number <> 0 Then MsgBox Err.Description Application.DisplayAlerts = True: Application.ScreenUpdating = True: Application.EnableEvents = True End Sub