Получение имён листов из закрытых книг

[jungo]

Сообщение от Serge_Bliznykov

попробуйте такой макрос:

Sub Кнопка1_Щелчок()
Dim i As Long, LastRow As Long, FN As String, FNamePath As String
Dim wbSrc As Workbook, shSrc As Worksheet

LastRow = ThisWorkbook.Worksheets("Лист1").Cells(Rows.Count, 1).End(xlUp).Row
FNamePath = ThisWorkbook.Path & "\"

On Error Resume Next
Application.ScreenUpdating = False
For i = 1 To LastRow
  FN = FNamePath & ThisWorkbook.Worksheets("Лист1").Cells(i, "A").Value
  Set wbSrc = Workbooks.Open(FN, ReadOnly:=True)
  Set shSrc = wbSrc.Worksheets(1)
  
  ThisWorkbook.Worksheets("Лист1").Cells(i, "B").Value = shSrc.Name
  
  wbSrc.Close False
Next
Application.ScreenUpdating = True

MsgBox " Готово!"
End Sub

p.s. собственно либо поместите это макрос в свою книгу,
где на "Лист1" в столбце A перечислены имена файлов (только имен, БЕЗ директории),
либо в макросе измените книгу и имя листа.
Файл должен находится там же, где находятся файлы.


p.p.s. код тупой и грубый, написал как мог...
Уверен, что тут есть форумчане, которые легко смогут его переписать красиво.
если это нужно

Что я делаю не так..?

Так как эксель амглийский, изменил название макроса и 'Лист1' на 'OMG'.
В столбце А восемь названий файлов вряд (пример: 459801283261_FINISH_0261.xls).
Не работает........

Пэ. Сэ. Не могу прикрепить пример или фото (не крепится)

[Hugo121]

Сообщение от jungo

Что я делаю не так..?

- вероятно не установили архиватор...

[jungo]

Сообщение от Hugo121

- вероятно не установили архиватор...

А можно по подробней? Мучаюсь уже месяц...

[Hugo121]

Подробнее - устанавливаете любой архиватор, архивируете свой файл/ы с неработающим кодом, архив прикрепляете к посту.

[jungo]

Сообщение от Hugo121

Подробнее - устанавливаете любой архиватор, архивируете свой файл/ы с неработающим кодом, архив прикрепляете к посту.

Загрузка файла прошла неудачно. Вот так все время, с любого компа...

А может кто то может выложить пример?
Только если можно на английском....

[jungo]

Дорогие друзья,
Я извиняюсь за то что морочу вам голову, но я уже близок к разгадке, мне нужна ваша помощь толко вдвух вещах:

1. Код работает прекрасно, но поочередно, по одной книги... Мне нужно что бы он работал со всеми книгами в папке.
2. Имя листа (всегда один) должно быть напротив имени его книги.

Sub GetListOfSheets()
Dim fName$, i As Long, rc As Long, y
Dim sPrv As String, sConStr As String
Dim f$, arr()

With Application.FileDialog(msoFileDialogFilePicker)
    .Title = "Please select a file": .InitialFileName = ThisWorkbook.Path
    .Filters.Add "Excel", "*.xls;*.xlsx;*.xlsm", 1: .AllowMultiSelect = False
    If .Show = False Then Exit Sub: If .SelectedItems.Count = 0 Then Exit Sub
    fName = .SelectedItems(1)
End With

If Val(Application.Version) < 12 Then
    sPrv = "Microsoft.Jet.OLEDB.4.0": sConStr = "Data Source=" & fName & ";Extended Properties=Excel 8.0;"
Else
    sPrv = "Microsoft.ACE.OLEDB.12.0": sConStr = "Data Source=" & fName & ";Extended Properties=Excel 12.0;"
End If

With New ADODB.Connection
    .Provider = sPrv: .ConnectionString = sConStr: .CursorLocation = adUseClient: .Open
    With .OpenSchema(adSchemaTables)
        '  With .OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, "Table"))' or so
        rc = .RecordCount
        ReDim arr(1 To rc + 1, 1 To 2)
        arr(1, 1) = "#Sheets": arr(1, 2) = fName
        For i = 1 To rc
            arr(i + 1, 1) = i: arr(i + 1, 2) = Replace(.Fields("TABLE_NAME").Value, "$", "")
            .MoveNext
        Next i
        .Close
    End With
    .Close
End With
Range("A1").CurrentRegion.ClearContents
Range("A1:B1").Resize(UBound(arr)).Value = arr()
End Sub

[IgorGO]

решение совершенно не в тему... но выполняет поставленную задачу

Sub InsSheetsName()
  Dim fName$, r&, sht As Worksheet, wb As Workbook, fso, f, ApSU
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Please select a folder": .InitialFileName = ThisWorkbook.Path: .AllowMultiSelect = False
    If .Show = False Then Exit Sub
    If .SelectedItems.Count = 0 Then Exit Sub Else fName = .SelectedItems(1)
  End With
  Set fso = CreateObject("Scripting.FileSystemObject"):  r = Cells(Rows.Count, 1).End(xlUp).Row
  If r > 1 Then Cells(2, 1).Resize(r - 1, 1).EntireRow.ClearContents
  r = 2: Set sht = ActiveSheet:  ApSU = Application.ScreenUpdating: Application.ScreenUpdating = False
  For Each f In fso.getfolder(fName).Files
    Application.StatusBar = f.Name
    If f.Name Like "*.xls*" Then
      Set wb = Workbooks.Open(f): sht.Cells(r, 1) = f.Name
      If wb.Worksheets.Count > 0 Then sht.Cells(r, 2) = wb.Worksheets(1).Name
      wb.Close False: r = r + 1
    End If
  Next
  Application.ScreenUpdating = ApSU:  Application.StatusBar = False
End Sub

[jungo]

Сообщение от IgorGO

решение совершенно не в тему... но выполняет поставленную задачу

Sub InsSheetsName()
  Dim fName$, r&, sht As Worksheet, wb As Workbook, fso, f, ApSU
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Please select a folder": .InitialFileName = ThisWorkbook.Path: .AllowMultiSelect = False
    If .Show = False Then Exit Sub
    If .SelectedItems.Count = 0 Then Exit Sub Else fName = .SelectedItems(1)
  End With
  Set fso = CreateObject("Scripting.FileSystemObject"):  r = Cells(Rows.Count, 1).End(xlUp).Row
  If r > 1 Then Cells(2, 1).Resize(r - 1, 1).EntireRow.ClearContents
  r = 2: Set sht = ActiveSheet:  ApSU = Application.ScreenUpdating: Application.ScreenUpdating = False
  For Each f In fso.getfolder(fName).Files
    Application.StatusBar = f.Name
    If f.Name Like "*.xls*" Then
      Set wb = Workbooks.Open(f): sht.Cells(r, 1) = f.Name
      If wb.Worksheets.Count > 0 Then sht.Cells(r, 2) = wb.Worksheets(1).Name
      wb.Close False: r = r + 1
    End If
  Next
  Application.ScreenUpdating = ApSU:  Application.StatusBar = False
End Sub

Все работает! Огромное спасибо!!!

[IgorGO]

к чему эта многозначительная цитата?

а решение совсем не в тему потому что: каждая книга открывается, данные считываются, книга закрывается.