Редактировать данную ячейку в серии excel workbooks

Question

У меня есть большое количество файлов Excel. Эти файлы я хочу добавить последовательность чисел (1500, 1501, ...) в конкретную ячейку.

Например, я хочу, ячейка A2 для имени файла «день1» будет 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 в том же каталоге, что и рабочая книга, содержащая этот макрос. Затем он выводит этот список в окно Immediate. Перед продолжением убедитесь, что список указан так, как вам нужно. Обратите внимание, что оператор 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 из Sub UpdateWorkbooks. Он открывает каждую книгу 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 

Удачи.

Answer 2

Да, это возможно, но я не верю, что есть простой способ достичь этого. Вам нужно будет написать код в VBA (или на самом деле любой язык, на котором есть библиотека Excel), чтобы открыть каждую книгу и обновить ячейку A2.

Пример this Пример 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 

Вы должны были бы написать функцию с именем GetFilenames, который возвращает массив имен файлов, которые вы хотите обновить этот пример работы.

Answer 3

Это последний код ... Благодаря Тони Даллимор

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