Question

我有大量的Excel文件。这些文件我想在特定单元格中添加一系列数字（1500,1501，...）。

例如，我希望文件名“Day1”的单元格A2为1500，下一个文件的相同单元格为1501，等等。

这可以使用VBA吗？

Answer 1

当我创建一个看起来好像我可能再次使用它的宏时，我将一个副本保存为资源文件夹中的文本文件。我找到了一些可以解决问题的例程。

我假设您将创建一个新工作簿，您将在其中放置代码。此工作簿不会更新。

以下例程有三个参数：

PathCrnt：要搜索文件的文件夹的名称。
FileSpec：标识所需文件名的模式。 “。”表示所有文件。 “ .xls”表示扩展名为“xls”的所有文件。 “文件 .txt”表示所有以“文件”开头，扩展名为“txt”的文件。
FileNameList：存储匹配文件名称的字符串数组。

我已经简化了这个例程，删除了你不需要的设施。

Sub GetFileNameList(ByVal PathCrnt As String, ByVal FileSpec As String, _
                                            ByRef FileNameList() As String)

' This routine sets FileNameList to the names of files within folder
' PathCrnt that match FileSpec.  It uses function Dir$() to get the file names.
' I can find no documentation that says Dir$() gets file names in alphabetic
' order but I have not seen a different sequence in recent years

  Dim AttCrnt As Long
  Dim FileNameCrnt As String
  Dim InxFNLCrnt As Long

  ReDim FileNameList(1 To 100)
  InxFNLCrnt = 0

  ' Ensure path name ends in a "\"
  If Right(PathCrnt, 1) <> "\" Then
    PathCrnt = PathCrnt & "\"
  End If

  ' This Dir$ returns the name of the first file in
  ' folder PathCrnt that matches FileSpec.
  FileNameCrnt = Dir$(PathCrnt & FileSpec)
  Do While FileNameCrnt <> ""
    ' "Files" have attributes, for example: normal, to-be-archived, system,
    ' hidden, directory and label. It is unlikely that any directory will
    ' have an extension of XLS but it is not forbidden.  More importantly,
    ' if the files have more than one extension so you have to use "*.*"
    ' instead of *.xls", Dir$ will return the names of directories. Labels
    ' can only appear in route directories and I have not bothered to test
    ' for them
    AttCrnt = GetAttr(PathCrnt & FileNameCrnt)
    If (AttCrnt And vbDirectory) <> 0 Then
      ' This "file" is a directory.  Ignore
    Else
      ' This "file" is a file
      InxFNLCrnt = InxFNLCrnt + 1
      If InxFNLCrnt > UBound(FileNameList) Then
        ' There is a lot of system activity behind "Redim Preserve".  I reduce
        ' the number of Redim Preserves by adding new entries in chunks and
        ' using InxFNLCrnt to identify the next free entry.
        ReDim Preserve FileNameList(1 To 100 + UBound(FileNameList))
      End If
      FileNameList(InxFNLCrnt) = FileNameCrnt
    End If
    ' This Dir$ returns the name of the next file that matches
    ' the criteria specified in the initial call.
    FileNameCrnt = Dir$
  Loop

  ' Discard the unused entries
  ReDim Preserve FileNameList(1 To InxFNLCrnt)

End Sub

以下宏不是一个完整的解决方案。但是，我建议您在查看下面更完整的解决方案之前确保此位正常工作。此例程使用GetFileNameList获取与包含此宏的工作簿相同的目录中的XLS文件列表。然后它将该列表输出到立即窗口。在继续之前，请确保列表符合您的要求。请注意，Option Explicit语句必须位于模块的顶部。

Option Explicit

Sub UpdateWorkbooks()

  Dim FileNameList() As String
  Dim InxFNLCrnt As Long
  Dim PathCrnt As String

  If Workbooks.Count > 1 Then
    ' It is easy to get into a muddle if there are multiple workbooks
    ' open at the start of a macro like this.  Avoid the problem until
    ' you understand it.
    Call MsgBox("Please close all other workbooks", vbOKOnly)
    Exit Sub
  End If

  ' For my testing, I placed the workbook containing
  ' this code in a folder full of XLS files.
  PathCrnt = ActiveWorkbook.Path & "\"

  Call GetFileNameList(PathCrnt, "*.xls", FileNameList)

  For InxFNLCrnt = 1 To UBound(FileNameList)
    Debug.Print FileNameList(InxFNLCrnt)
  Next

End Sub

以下代码就在End Sub的{{1}}之前。它打开每个Excel工作簿，并将其名称和第一个工作表的名称输出到立即窗口。我再次建议你在继续之前确保这是有效的。

Sub UpdateWorkbooks

我不想更新我的工作簿，也不想创建一组测试工作簿，因此下面的代码尚未经过测试。这很简单，所以我应该第一次做对，但我仍然会仔细测试。我建议您创建一个Test文件夹，将包含此答案中的代码的工作簿和一个Excel工作簿复制到该文件夹。注意：复制不动！使用那个Excel工作簿测试宏。如果对第一个工作簿的处理方式感到满意，请复制第二个工作簿并再次测试。如果宏正确处理两个工作簿，它应该处理任何数字。但是，我会保存所有工作簿的副本，直到您使用序列号并且它们按预期执行。

  Dim SeqNum as long
  Dim WBookOther As Workbook

  SeqNum = 1500   

  For InxFNLCrnt = 1 To UBound(FileNameList)
    If FileNameList(InxFNLCrnt) = ActiveWorkbook.Name Then
      ' Ignore this workbook
    Else
      Set WBookOther = Workbooks.Open(PathCrnt & FileNameList(InxFNLCrnt))
      With WBookOther
        ' ### When you add the next block of code, I suggest you
        ' delete this Debug.Print.
        Debug.Print FileNameList(InxFNLCrnt) & "   " & .Sheets(1).Name

        ' ##### The next block of code will go here #####            

      .Close SaveChanges:=False  ' Close the workbook without saving again
      Set WBookOther = Nothing   ' Clear reference to workbook
      End With
    End If
  Next

祝你好运。

Answer 2

是的，这是可能的，但我不相信有一个简单的方法来实现这一目标。您需要在VBA（或任何具有Excel库的语言）中编写一些代码来打开每个工作簿并更新单元格A2。

查看某些VBA的this示例，该示例与您想要做的事情相似。我复制了相关的代码示例：

Sub WorkbooksLoop()    
    ' get the list of filenames
    Dim filenames() As String
    filenames = GetFilenames()

    ' an error will be thrown if there are no files, just skip loop and end normally
    On Error GoTo NoFilenames

    ' save a handle to the current workbook so we can switch back and forth between workbooks
    Dim controllerwb As Workbook
    Set controllerwb = ActiveWorkbook
    Dim wb As Workbook
    Dim fname As Variant

    ' Find the current path for this file to use in opening workbooks in the same directory
    Dim rootPath As String
    rootPath = ThisWorkbook.Path
    rootPath = rootPath & "\"

    For Each fname In filenames
        ' Make the controller active
        controllerwb.Activate

        On Error Resume Next
        ' If activate fails, then the workbook isn't open
        Workbooks(fname).Activate
        ' If activate fails, then the workbook isn't open
        If Err <> 0 Then
            ' open the workbook
            Set wb = Workbooks.Open(rootPath & fname)
            ' then activate it
            wb.Activate
        ' Otherwise, workbook is already open, refer to it by name
        Else
            Set wb = Workbooks(fname)
        End If

        ' do something to the open workbook
        wb.Cells(1,1).Value = "Sweet!"

        ' Save and Close the workbook
        wb.Save
        wb.Close
    Next fname
NoFilenames:
End Sub

您需要编写一个名为GetFilenames的函数，该函数返回您要更新的文件名数组，以使此示例正常工作。

Answer 3

这是最终的代码......感谢Tony Dallimore

Option Explicit
Sub GetFileNameList(ByVal PathCrnt As String, ByVal FileSpec As String, _
                                            ByRef FileNameList() As String)
  Dim AttCrnt As Long
  Dim FileNameCrnt As String
  Dim InxFNLCrnt As Long

  ReDim FileNameList(1 To 100)
  InxFNLCrnt = 0

  ' Ensure path name ends in a "\"
  If Right(PathCrnt, 1) <> "" Then
        PathCrnt = PathCrnt & "\"
  End If

  ' This Dir$ returns the name of the first file in
  ' folder PathCrnt that matches FileSpec.
  FileNameCrnt = Dir$(PathCrnt & FileSpec)
  Do While FileNameCrnt <> ""
    ' "Files" have attributes, for example: normal, to-be-archived, system,
    ' hidden, directory and label. It is unlikely that any directory will
    ' have an extension of XLS but it is not forbidden.  More importantly,
    ' if the files have more than one extension so you have to use "*.*"
    ' instead of *.xls", Dir$ will return the names of directories. Labels
    ' can only appear in route directories and I have not bothered to test
    ' for them
    AttCrnt = GetAttr(PathCrnt & FileNameCrnt)
    If (AttCrnt And vbDirectory) <> 0 Then
      ' This "file" is a directory.  Ignore
    Else
      ' This "file" is a file
      InxFNLCrnt = InxFNLCrnt + 1
      If InxFNLCrnt > UBound(FileNameList) Then
        ' There is a lot of system activity behind "Redim Preserve".  I reduce
        ' the number of Redim Preserves by adding new entries in chunks and
        ' using InxFNLCrnt to identify the next free entry.
        ReDim Preserve FileNameList(1 To 100 + UBound(FileNameList))
      End If
      FileNameList(InxFNLCrnt) = FileNameCrnt
    End If
    ' This Dir$ returns the name of the next file that matches
    ' the criteria specified in the initial call.
    FileNameCrnt = Dir$
  Loop

  ' Discard the unused entries
  ReDim Preserve FileNameList(1 To InxFNLCrnt)

End Sub



Sub UpdateWorkbooks()

  Dim FileNameList() As String
  Dim InxFNLCrnt As Long
  Dim PathCrnt As String

  If Workbooks.Count > 1 Then
    ' It is easy to get into a muddle if there are multiple workbooks
    ' open at the start of a macro like this.  Avoid the problem until
    ' you understand it.
    Call MsgBox("Please close all other workbooks", vbOKOnly)
    Exit Sub
  End If

  ' For my testing, I placed the workbook containing
  ' this code in a folder full of XLS files.
  PathCrnt = ActiveWorkbook.Path & "\"

  Call GetFileNameList(PathCrnt, "*.xlsx", FileNameList)

  For InxFNLCrnt = 1 To UBound(FileNameList)
    Debug.Print FileNameList(InxFNLCrnt)
  Next

  Dim SeqNum As Long
  Dim WBookOther As Workbook

  SeqNum = 1604

  For InxFNLCrnt = 1 To UBound(FileNameList)
    If FileNameList(InxFNLCrnt) = ActiveWorkbook.Name Then
      ' Ignore this workbook
    Else
      Set WBookOther = Workbooks.Open(PathCrnt & FileNameList(InxFNLCrnt))
      With WBookOther
      With Sheets("sheet2")    ' Replace "xxxxxx" with the name of your worksheet'
          Debug.Print "Workbook"; WBookOther.Name
          Debug.Print "  Cell A6 changed from [" & .Range("A6").Value & _
                      "] to [" & SeqNum & "]"
          .Range("A6").Value = SeqNum
          SeqNum = SeqNum + 1   ' Ready for next workbook
        End With
        .Save           ' Save changed workbook

      .Close SaveChanges:=False  ' Close the workbook without saving again
      Set WBookOther = Nothing   ' Clear reference to workbook
      End With
    End If
  Next

End Sub

编辑一系列excel工作簿中的给定单元格

3 个答案: