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

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

excel vba

编辑一系列excel工作簿中的给定单元格,excel,vba,Excel,Vba,我有大量的Excel文件。这些文件我想在特定单元格中添加一系列数字（15001501，…）例如，我希望文件名“Day1”的单元格A2为1500，下一个文件的相同单元格为1501，以此类推使用VBA可以做到这一点吗？是的，这是可能的，但我不相信有简单的方法可以做到这一点。您需要用VBA（或者任何有Excel库的语言）编写一些代码来打开每个工作簿并更新单元格A2 查看一些VBA的例子，它们与您想要做的事情相对类似。我复制了相关的代码示例： Sub WorkbooksLoop()

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

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

使用VBA可以做到这一点吗？

是的，这是可能的，但我不相信有简单的方法可以做到这一点。您需要用VBA（或者任何有Excel库的语言）编写一些代码来打开每个工作簿并更新单元格A2

查看一些VBA的例子，它们与您想要做的事情相对类似。我复制了相关的代码示例：

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

子工作簿循环（）
'获取文件名列表
Dim filenames（）作为字符串
filenames=GetFilenames（）
'如果没有文件，将抛出错误，只需跳过循环并正常结束
转到NoFilenames时出错
'保存当前工作簿的句柄，以便在工作簿之间来回切换
Dim CONTROLLERB As工作簿
Set controllerwb=ActiveWorkbook
将wb设置为工作簿
Dim fname作为变体
'查找此文件在打开同一目录中的工作簿时使用的当前路径
将根路径设置为字符串
rootPath=ThisWorkbook.Path
rootPath=rootPath&“\”
对于文件名中的每个fname
'使控制器处于活动状态
控制器B.启动
出错时继续下一步
'如果激活失败，则工作簿未打开
工作簿（fname）。激活
'如果激活失败，则工作簿未打开
如果错误为0，则
'打开工作簿
设置wb=Workbooks.Open（rootPath&fname）
“然后激活它
wb.激活
'否则，工作簿已打开，请按名称引用它
其他的
设置wb=工作簿（fname）
如果结束
'对打开的工作簿执行某些操作
wb.Cells（1,1）.Value=“Sweet！”
'保存并关闭工作簿
wb.保存
wb.关闭
下一个fname
无文件名：
端接头

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

当我创建一个看起来可能再次使用的宏时，我会将一个副本保存为resources文件夹中的文本文件。我找到了一些可以解决你问题的常规方法

我假设您将创建一个新工作簿，并将下面的代码放入其中。此工作簿将不会更新

以下例程采用三个参数：

PathCrnt：要搜索文件的文件夹的名称
FileSpec：标识所需文件名的模式。“.”指所有文件。“.xls”是指扩展名为“xls”的所有文件。“File.txt”是指以“File”和“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

下面的代码正好位于

子更新工作簿

的

结束子部分

之前。它打开每个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

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

        With Sheets("xxxxx")    ' Replace "xxxxx" with the name of your worksheet 
          Debug.Print "Workbook " WBookOther.Name
          Debug.Print "  Cell A2 changed from [" & .Range("A2").Value & _
                      "] to [" & SeqNum & "]"  
          .Range("A2").Value = SeqNum
          SeqNum = SeqNum + 1   ' Ready for next workbook
        End With
        .Save           ' Save changed workbook

祝你好运。

这是最后的代码。。。多亏了托尼·达利莫尔

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

选项显式
子GetFileNameList（ByVal PathCrnt作为字符串，ByVal FileSpec作为字符串_
ByRef FileNameList（）作为字符串）
暗色调与长色调相同
Dim FileNameCrnt作为字符串
长时变暗
ReDim文件名列表（1到100）
InxFNLCrnt=0
'确保路径名以“\”结尾'
如果正确（路径号，1）”，则
PathCrnt=PathCrnt&“\”
如果结束
'此Dir$返回中第一个文件的名称
'与FileSpec匹配的文件夹路径。
FileNameCrnt=Dir$（PathCrnt&FileSpec）
当文件名为“”时执行此操作
“文件”具有属性，例如：正常、要存档、系统、，
'隐藏、目录和标签。任何目录都不太可能
'具有XLS的扩展，但这不是禁止的。更重要的是,，
'如果文件有多个扩展名，则必须使用“***”
“而不是*.xls”，Dir$将返回目录的名称。标签
'只能出现在路由目录中，我没有费心测试
“为了他们
AttCrnt=GetAttr（路径号和文件名号）
如果（AttCrnt和vbDirectory）为0，则
'此“文件”是一个目录。忽略
其他的
'此“文件”是一个文件
InxFNLCrnt=InxFNLCrnt+1
如果InxFNLCrnt>UBound（文件名列表），则
'在“Redim Preserve”后面有很多系统活动。我减少了
'通过在块中添加新条目和
'使用InxFNLCrnt识别下一个自由条目。
重拨保留文件名列表（1到100+UBound（文件名列表））
如果结束
FileNameList（InxFNLCrnt）=FileNameCrnt
如果结束
'此Dir$返回下一个匹配文件的名称
'初始调用中指定的条件。
FileNameCrnt=Dir$
环
'放弃未使用的条目
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