Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Объединение файлов с доп. столбцом - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Объединение файлов с доп. столбцом (Макросы/Sub)
Объединение файлов с доп. столбцом
AnRusik Дата: Вторник, 21.12.2021, 10:44 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 1 ±
Замечаний: 20% ±

2010
Делаю выгрузку из программы по техническим характеристикам на изделия. Изделий порядка 1000. Нужно сделать что-то типа базы данных.
Нашел макрос по объединению dbf файлов:
[vba]
Код
Sub Wowanich()
Const dir = "C:\test" 'Вставь правильный путь !!!
ChDir dir
Set fso = CreateObject("scripting.filesystemobject")
For Each ff In fso.getfolder(dir).Files
Set blank_cell = Cells(Range("a1").SpecialCells(xlCellTypeLastCell).Row + 1, 1)
If Right(ff.Name, 4) = ".dbf" Then
Set dbf = Workbooks.Open(Filename:=ff.Name, ReadOnly:=True)
dbf.Sheets(1).Range("a2", Range("a1").SpecialCells(xlCellTypeLastCell)).Copy blank_cell
dbf.Close
End If
Next
End Sub
[/vba]
Как можно дописать его, чтобы вставлялся доп.столбец с именем файла. Имя файла выглядит что-то типа: Кубик_Таблицы операций_Общая.dbf. Из имени файла нужно вытащить именно название "Кубик", т.е. то, что идет до знака "_".
К сообщению приложен файл: ___.dbf (17.1 Kb) · ______.dbf (2.5 Kb) · _dbf.xls (45.5 Kb)


Сообщение отредактировал AnRusik - Вторник, 21.12.2021, 11:49
 
Ответить
СообщениеДелаю выгрузку из программы по техническим характеристикам на изделия. Изделий порядка 1000. Нужно сделать что-то типа базы данных.
Нашел макрос по объединению dbf файлов:
[vba]
Код
Sub Wowanich()
Const dir = "C:\test" 'Вставь правильный путь !!!
ChDir dir
Set fso = CreateObject("scripting.filesystemobject")
For Each ff In fso.getfolder(dir).Files
Set blank_cell = Cells(Range("a1").SpecialCells(xlCellTypeLastCell).Row + 1, 1)
If Right(ff.Name, 4) = ".dbf" Then
Set dbf = Workbooks.Open(Filename:=ff.Name, ReadOnly:=True)
dbf.Sheets(1).Range("a2", Range("a1").SpecialCells(xlCellTypeLastCell)).Copy blank_cell
dbf.Close
End If
Next
End Sub
[/vba]
Как можно дописать его, чтобы вставлялся доп.столбец с именем файла. Имя файла выглядит что-то типа: Кубик_Таблицы операций_Общая.dbf. Из имени файла нужно вытащить именно название "Кубик", т.е. то, что идет до знака "_".
Автор - AnRusik
Дата добавления - 21.12.2021 в 10:44
китин Дата: Вторник, 21.12.2021, 10:52 | Сообщение № 2
Группа: Модераторы
Ранг: Экселист
Сообщений: 7029
Репутация: 1078 ±
Замечаний: 0% ±

Excel 2007;2010;2016
AnRusik, - Прочитайте Правила форума
- Приложите файл с исходными данными и желаемым результатом (можно вручную) в формате Excel размером до 500 кб согласно п.3 Правил форума
- Оформите код тегами (в режиме правки поста выделите код и нажмите кнопку #, пояснялка здесь)
Помогающим просьба воздержаться от ответов в этой теме до исправления замечания

исправлено

Не судите очень строго:я пытаюсь научиться
ЯД 41001877306852

Сообщение отредактировал Pelena - Вторник, 21.12.2021, 14:07
 
Ответить
СообщениеAnRusik, - Прочитайте Правила форума
- Приложите файл с исходными данными и желаемым результатом (можно вручную) в формате Excel размером до 500 кб согласно п.3 Правил форума
- Оформите код тегами (в режиме правки поста выделите код и нажмите кнопку #, пояснялка здесь)
Помогающим просьба воздержаться от ответов в этой теме до исправления замечания

исправлено
Автор - китин
Дата добавления - 21.12.2021 в 10:52
Pelena Дата: Вторник, 21.12.2021, 14:44 | Сообщение № 3
Группа: Админы
Ранг: Местный житель
Сообщений: 19403
Репутация: 4555 ±
Замечаний: ±

Excel 365 & Mac Excel
Так проверьте
[vba]
Код
Sub Wowanich()
    Const dir = "C:\test" 'Вставь правильный путь !!!
    ChDir dir
    Set fso = CreateObject("scripting.filesystemobject")
    For Each ff In fso.getfolder(dir).Files
        Set blank_cell = Cells(Range("A1").SpecialCells(xlCellTypeLastCell).Row + 1, 1)
        If Right(ff.Name, 4) = ".dbf" Then
            Set dbf = Workbooks.Open(Filename:=ff.Path, ReadOnly:=True)
            dbf.Sheets(1).Range("a2", dbf.Sheets(1).Range("a1").SpecialCells(xlCellTypeLastCell)).Copy blank_cell.Offset(, 1)
            blank_cell.Resize(dbf.Sheets(1).Range("a2", dbf.Sheets(1).Range("a1").SpecialCells(xlCellTypeLastCell)).Rows.Count) = Split(ff.Name & "_", "_")(0)
            dbf.Close
        End If
    Next
End Sub
[/vba]

"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
СообщениеТак проверьте
[vba]
Код
Sub Wowanich()
    Const dir = "C:\test" 'Вставь правильный путь !!!
    ChDir dir
    Set fso = CreateObject("scripting.filesystemobject")
    For Each ff In fso.getfolder(dir).Files
        Set blank_cell = Cells(Range("A1").SpecialCells(xlCellTypeLastCell).Row + 1, 1)
        If Right(ff.Name, 4) = ".dbf" Then
            Set dbf = Workbooks.Open(Filename:=ff.Path, ReadOnly:=True)
            dbf.Sheets(1).Range("a2", dbf.Sheets(1).Range("a1").SpecialCells(xlCellTypeLastCell)).Copy blank_cell.Offset(, 1)
            blank_cell.Resize(dbf.Sheets(1).Range("a2", dbf.Sheets(1).Range("a1").SpecialCells(xlCellTypeLastCell)).Rows.Count) = Split(ff.Name & "_", "_")(0)
            dbf.Close
        End If
    Next
End Sub
[/vba]
Автор - Pelena
Дата добавления - 21.12.2021 в 14:44
AnRusik Дата: Вторник, 21.12.2021, 16:07 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 1 ±
Замечаний: 20% ±

2010
hands hands Супер - Спасибо. Все работает!
 
Ответить
Сообщениеhands hands Супер - Спасибо. Все работает!
Автор - AnRusik
Дата добавления - 21.12.2021 в 16:07
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Объединение файлов с доп. столбцом (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!