vba - Excel VBA - 从多个工作簿中的数据创建多个文件

Question

我想运行一个宏来从工作表中提取某些单元格，然后创建一个具有相同名称的 csv 文件。我还想在整个文件夹上运行宏，因为有 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