Форум программистов
 
Контакты: о проблемах с регистрацией, почтой и по другим вопросам пишите сюда - alarforum@yandex.ru, проверяйте папку спам! Обязательно пройдите активизацию e-mail.

Вернуться   Форум программистов > Microsoft Office и VBA > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Ответ
 
Опции темы
Старый 13.11.2018, 20:37   #21
jungo
Форумчанин
 
Аватар для jungo
 
Регистрация: 14.11.2007
Сообщений: 158
Репутация: 10
По умолчанию

Цитата:
Сообщение от 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).
Не работает........

Пэ. Сэ. Не могу прикрепить пример или фото (не крепится)
__________________
Jungo must die!!! (C) Bill Gates.
jungo вне форума   Ответить с цитированием
Старый 13.11.2018, 20:48   #22
Hugo121
Профессионал
 
Регистрация: 11.05.2010
Сообщений: 5,020
Репутация: 464
По умолчанию

Цитата:
Сообщение от jungo Посмотреть сообщение
Что я делаю не так..?
- вероятно не установили архиватор...
__________________
webmoney: E265281470651 Z422237915069 R418926282008
Hugo121 вне форума   Ответить с цитированием
Старый 13.11.2018, 20:59   #23
jungo
Форумчанин
 
Аватар для jungo
 
Регистрация: 14.11.2007
Сообщений: 158
Репутация: 10
По умолчанию

Цитата:
Сообщение от Hugo121 Посмотреть сообщение
- вероятно не установили архиватор...
А можно по подробней? Мучаюсь уже месяц...
__________________
Jungo must die!!! (C) Bill Gates.
jungo вне форума   Ответить с цитированием
Старый 13.11.2018, 21:16   #24
Hugo121
Профессионал
 
Регистрация: 11.05.2010
Сообщений: 5,020
Репутация: 464
По умолчанию

Подробнее - устанавливаете любой архиватор, архивируете свой файл/ы с неработающим кодом, архив прикрепляете к посту.
__________________
webmoney: E265281470651 Z422237915069 R418926282008
Hugo121 вне форума   Ответить с цитированием
Старый 13.11.2018, 21:29   #25
jungo
Форумчанин
 
Аватар для jungo
 
Регистрация: 14.11.2007
Сообщений: 158
Репутация: 10
По умолчанию

Цитата:
Сообщение от Hugo121 Посмотреть сообщение
Подробнее - устанавливаете любой архиватор, архивируете свой файл/ы с неработающим кодом, архив прикрепляете к посту.
Загрузка файла прошла неудачно. Вот так все время, с любого компа...

А может кто то может выложить пример?
Только если можно на английском....
__________________
Jungo must die!!! (C) Bill Gates.
jungo вне форума   Ответить с цитированием
Старый 14.11.2018, 15:42   #26
jungo
Форумчанин
 
Аватар для jungo
 
Регистрация: 14.11.2007
Сообщений: 158
Репутация: 10
По умолчанию

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

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

__________________
Jungo must die!!! (C) Bill Gates.
jungo вне форума   Ответить с цитированием
Старый 14.11.2018, 16:29   #27
IgorGO
МегаМодератор
СуперМодератор
 
Аватар для IgorGO
 
Регистрация: 05.02.2008
Адрес: УКРАЇНА, Київ
Сообщений: 9,056
Репутация: 1711

icq: 7934250
skype: i2x0,5
По умолчанию

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

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

__________________
41001804815208 - Яндекс-деньги благодарности за удачные советы и решения можно отправлять прямо сюда)
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете
IgorGO вне форума   Ответить с цитированием
Старый 14.11.2018, 17:24   #28
jungo
Форумчанин
 
Аватар для jungo
 
Регистрация: 14.11.2007
Сообщений: 158
Репутация: 10
По умолчанию

Цитата:
Сообщение от 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 must die!!! (C) Bill Gates.
jungo вне форума   Ответить с цитированием
Старый 14.11.2018, 19:38   #29
IgorGO
МегаМодератор
СуперМодератор
 
Аватар для IgorGO
 
Регистрация: 05.02.2008
Адрес: УКРАЇНА, Київ
Сообщений: 9,056
Репутация: 1711

icq: 7934250
skype: i2x0,5
По умолчанию

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

а решение совсем не в тему потому что: каждая книга открывается, данные считываются, книга закрывается.
__________________
41001804815208 - Яндекс-деньги благодарности за удачные советы и решения можно отправлять прямо сюда)
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете
IgorGO вне форума   Ответить с цитированием
Ответ

Опции темы

Ваши права в разделе
Вы не можете создавать новые темы
Вы не можете отвечать в темах
Вы не можете прикреплять вложения
Вы не можете редактировать свои сообщения

BB коды Вкл.
Смайлы Вкл.
[IMG] код Вкл.
HTML код Выкл.

Быстрый переход

Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Обьединение листов из закрытых книг Extril Microsoft Office Excel 31 28.11.2013 12:55
Получение имён, отправка ID. Как правильно обработать? Jopses JavaScript, Ajax 0 02.02.2013 02:54
Макрос аля ВПР для формирования свода из закрытых книг MaxxVer Microsoft Office Excel 15 28.08.2012 12:02
Получение данных из множества закрытых книг книг hardkain Microsoft Office Excel 1 27.09.2011 20:18
копирование листов из закрытых книг mephist Microsoft Office Excel 4 10.07.2009 17:18


08:29.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.

RusProfile.ru


Справочник российских юридических лиц и организаций.
Проекты отопления, пеллетные котлы, бойлеры, радиаторы
интернет магазин respective.ru