Прочитайте файл и создайте таблицу

Question

Я ищу помощи в сложной миссии. У меня есть более 30 000 файлов в определенной папке (* \ backup) в xl ?? формат и нужно читать ячейку B4. Я думал, что лучшая идея - использовать VBA в Excel, чтобы прочитать эту конкретную ячейку для каждого файла и записать в таблицу A: B.

Answer 1

Я полагаю, что следующее должно помочь вам, просто не забудьте изменить объявление для имени рабочего листа назначения и полного пути к папке, в которой находятся рабочие книги, которые вы хотите прочитать.

Приведенный ниже код будет проходить по циклувыберите нужный каталог / папку и прочитайте все файлы с расширением .xls *, получите значение из первого рабочего листа в ячейке B4 и передайте это значение в конечный рабочий лист.

Sub LoopAllExcelFilesInFolder()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim wsDestination As Worksheet: Set wsDestination = ThisWorkbook.Worksheets("Sheet1")
'declare and set the worksheet where you want to aggregate the data.

'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
  Application.CutCopyMode = False

myPath = "C:\backup\"
'set the full path to the folder you want to utilize, remember to add the last \

Last = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row
If Last >= 2 Then wsDestination.Range("A2:B" & Last).ClearContents
'clear the destination worksheet ready to aggregate again

myExtension = "*.xls*"
'Target File Extension (must include wildcard "*")

myFile = Dir(myPath & myExtension)
'Target Path with Ending Extention

Do While myFile <> ""
'Loop through each Excel file in folder
    Set wb = Workbooks.Open(Filename:=myPath & myFile)
    DoEvents
    'Ensure Workbook has opened before moving on to next line of code
    wsDestination.Cells(1, "A").Value = "Filename"
    wsDestination.Cells(1, "B").Value = "Value From Cell B4"

    NextRow = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Offset(1, 0).Row

    wsDestination.Cells(NextRow, "A").Value = myFile
    wsDestination.Cells(NextRow, "B").Value = wb.Worksheets(1).Range("B4").Value
    wb.Close SaveChanges:=False
    'Close Workbook without Saving
    DoEvents
    'Ensure Workbook has closed before moving on to next line of code
    myFile = Dir
    'Next File
Loop

MsgBox "Transfer of Data Completed!", vbInformation, "Info"
'Message Box when tasks are completed

ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub