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

Вход

Регистрация

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

 

= Мир MS Excel/Копирование из книги, у которой иногда меняется название - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Копирование из книги, у которой иногда меняется название
stns Дата: Воскресенье, 30.07.2023, 11:28 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 20% ±

Excel 2013
Здравствуйте! Просьба о помощи. Я новичок, как смог так и написал макрос для извлечения данных из одной книги, в другую - Трассовка ЮКМ (2 нитка), сохранение там в определенных столбцах для дальнейшего раскидывания данных по таблице с помощью формул. Соглашусь, что макрос выглядит громоздко и можно было это все оформить быстро и по другому, но как смог так и сделал, главное работает.
Вопрос в том, что так и не смог найти элементарного – в названии книги, из которой извлекаются данные, регулярно меняется дата и может меняться часть текста. Вставляю в папку этот присылаемый мне файл сам день через день. Пытался с помощью dim, но так и не получилось, не смог понять куда чего ставить. И также у этой книги может меняться расширение .xls .xlsx .xlsm. Еще не получилось прикрутить формулу ЕСЛИ(ЕЧИСЛО(ПОИСК("AN";C3));"A";"O") в столбец G, поставил вручную.
PS И еще, иногда требуется извлечение так, чтобы все располагалось снизу вверх, как бы наоборот – вверху стояло сначала нижнее значение и так далее. И так по всем столбцам, кроме столбца А – нумерации.
Старался максимально понятно выразиться. Буду благодарен за решение этого вопроса.
К сообщению приложен файл: dlja_foruma.rar (478.4 Kb)
 
Ответить
СообщениеЗдравствуйте! Просьба о помощи. Я новичок, как смог так и написал макрос для извлечения данных из одной книги, в другую - Трассовка ЮКМ (2 нитка), сохранение там в определенных столбцах для дальнейшего раскидывания данных по таблице с помощью формул. Соглашусь, что макрос выглядит громоздко и можно было это все оформить быстро и по другому, но как смог так и сделал, главное работает.
Вопрос в том, что так и не смог найти элементарного – в названии книги, из которой извлекаются данные, регулярно меняется дата и может меняться часть текста. Вставляю в папку этот присылаемый мне файл сам день через день. Пытался с помощью dim, но так и не получилось, не смог понять куда чего ставить. И также у этой книги может меняться расширение .xls .xlsx .xlsm. Еще не получилось прикрутить формулу ЕСЛИ(ЕЧИСЛО(ПОИСК("AN";C3));"A";"O") в столбец G, поставил вручную.
PS И еще, иногда требуется извлечение так, чтобы все располагалось снизу вверх, как бы наоборот – вверху стояло сначала нижнее значение и так далее. И так по всем столбцам, кроме столбца А – нумерации.
Старался максимально понятно выразиться. Буду благодарен за решение этого вопроса.

Автор - stns
Дата добавления - 30.07.2023 в 11:28
stns Дата: Понедельник, 31.07.2023, 04:03 | Сообщение № 2
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 20% ±

Excel 2013
Упростил свой вопрос и книги с данными. Хотябы такую задачу разрешить.

Из "Книга1 31.07.2023.xlsx" копируем в "Книга2" через один столбец. Нельзя ли упростить макрос?
И если файл потом станет называться "Книга1 01.08.2023", а потом "Книга1 15.08.2023", как заставить работать макрос?

[vba]
Код
Sub test()

'Открываем файл с которого нужно скопировать данные
Workbooks.Open Filename:="C:\Макрос\Книга1 31.07.2023.xlsx"
'Скопировать нужный диапазон в открывшейся книге на листе 1
Workbooks("Книга1 31.07.2023.xlsx").Worksheets("Лист1").Range("A8:A25").Copy
'Активируем нужную нам книгу
Workbooks("Книга2.xlsm").Activate
'Выделяем и вставляем скопированные данные в ячейку A3
ActiveWorkbook.Worksheets("Лист1").Range("A3").Select
ActiveSheet.Paste

Workbooks("Книга1 31.07.2023.xlsx").Worksheets("Лист1").Range("C8:C25").Copy
Workbooks("Книга2.xlsm").Activate
ActiveWorkbook.Worksheets("Лист1").Range("B3").Select
ActiveSheet.Paste

Workbooks("Книга1 31.07.2023.xlsx").Worksheets("Лист1").Range("E8:E25").Copy
Workbooks("Книга2.xlsm").Activate
ActiveWorkbook.Worksheets("Лист1").Range("C3").Select
ActiveSheet.Paste

Workbooks("Книга1 31.07.2023.xlsx").Worksheets("Лист1").Range("G9:G25").Copy
Workbooks("Книга2.xlsm").Activate
ActiveWorkbook.Worksheets("Лист1").Range("D3").Select
ActiveSheet.Paste

Workbooks("Книга1 31.07.2023.xlsx").Worksheets("Лист1").Range("I9:I25").Copy
Workbooks("Книга2.xlsm").Activate
ActiveWorkbook.Worksheets("Лист1").Range("E3").Select
ActiveSheet.Paste

Workbooks("Книга1 31.07.2023.xlsx").Worksheets("Лист1").Range("K8:K25").Copy
Workbooks("Книга2.xlsm").Activate
ActiveWorkbook.Worksheets("Лист1").Range("F3").Select
ActiveSheet.Paste
End Sub
[/vba]
К сообщению приложен файл: kniga2.xlsm (19.5 Kb) · kniga1_31_07_2023.xlsx (10.8 Kb)


Сообщение отредактировал Serge_007 - Понедельник, 31.07.2023, 08:34
 
Ответить
СообщениеУпростил свой вопрос и книги с данными. Хотябы такую задачу разрешить.

Из "Книга1 31.07.2023.xlsx" копируем в "Книга2" через один столбец. Нельзя ли упростить макрос?
И если файл потом станет называться "Книга1 01.08.2023", а потом "Книга1 15.08.2023", как заставить работать макрос?

[vba]
Код
Sub test()

'Открываем файл с которого нужно скопировать данные
Workbooks.Open Filename:="C:\Макрос\Книга1 31.07.2023.xlsx"
'Скопировать нужный диапазон в открывшейся книге на листе 1
Workbooks("Книга1 31.07.2023.xlsx").Worksheets("Лист1").Range("A8:A25").Copy
'Активируем нужную нам книгу
Workbooks("Книга2.xlsm").Activate
'Выделяем и вставляем скопированные данные в ячейку A3
ActiveWorkbook.Worksheets("Лист1").Range("A3").Select
ActiveSheet.Paste

Workbooks("Книга1 31.07.2023.xlsx").Worksheets("Лист1").Range("C8:C25").Copy
Workbooks("Книга2.xlsm").Activate
ActiveWorkbook.Worksheets("Лист1").Range("B3").Select
ActiveSheet.Paste

Workbooks("Книга1 31.07.2023.xlsx").Worksheets("Лист1").Range("E8:E25").Copy
Workbooks("Книга2.xlsm").Activate
ActiveWorkbook.Worksheets("Лист1").Range("C3").Select
ActiveSheet.Paste

Workbooks("Книга1 31.07.2023.xlsx").Worksheets("Лист1").Range("G9:G25").Copy
Workbooks("Книга2.xlsm").Activate
ActiveWorkbook.Worksheets("Лист1").Range("D3").Select
ActiveSheet.Paste

Workbooks("Книга1 31.07.2023.xlsx").Worksheets("Лист1").Range("I9:I25").Copy
Workbooks("Книга2.xlsm").Activate
ActiveWorkbook.Worksheets("Лист1").Range("E3").Select
ActiveSheet.Paste

Workbooks("Книга1 31.07.2023.xlsx").Worksheets("Лист1").Range("K8:K25").Copy
Workbooks("Книга2.xlsm").Activate
ActiveWorkbook.Worksheets("Лист1").Range("F3").Select
ActiveSheet.Paste
End Sub
[/vba]

Автор - stns
Дата добавления - 31.07.2023 в 04:03
Nic70y Дата: Понедельник, 31.07.2023, 09:38 | Сообщение № 3
Группа: Друзья
Ранг: Экселист
Сообщений: 8857
Репутация: 2308 ±
Замечаний: 0% ±

Excel 2010
[vba]
Код
Sub test()
    UserForm1.Show
End Sub
[/vba]

апдэйт, исправил
[vba]
Код
Private Sub UserForm_Activate()
    Dim arr()
    a = TextBox1.Value
    b = Dir(a & "\*.xls*")
    c = ThisWorkbook.Name
    n = 0
    i = 1
    Do While b <> ""
        ReDim Preserve arr(n)
        If b <> c Then
            arr(n) = b
            n = n + 1
            i = i + 1
        End If
        b = Dir
    Loop
    ListBox1.List = arr()
End Sub
Private Sub CommandButton1_Click()
    x = ListBox1.ListIndex
    If x = -1 Then
        MsgBox "Файл не выбран!"
    Else
        a = TextBox1.Value
        b = ListBox1.Value
        Workbooks.Open Filename:=a & b
        Range("C5:C25,E5:E25,G5:G25,I5:I25,K5:K25").Copy ThisWorkbook.Sheets("Лист1").Range("a3")
        Workbooks(b).Close False
        Unload UserForm1
    End If
End Sub
[/vba]
К сообщению приложен файл: 8490259.gif (15.3 Kb) · 8151144.xlsm (21.2 Kb)


ЮMoney 41001841029809

Сообщение отредактировал Nic70y - Понедельник, 31.07.2023, 10:09
 
Ответить
Сообщение[vba]
Код
Sub test()
    UserForm1.Show
End Sub
[/vba]

апдэйт, исправил
[vba]
Код
Private Sub UserForm_Activate()
    Dim arr()
    a = TextBox1.Value
    b = Dir(a & "\*.xls*")
    c = ThisWorkbook.Name
    n = 0
    i = 1
    Do While b <> ""
        ReDim Preserve arr(n)
        If b <> c Then
            arr(n) = b
            n = n + 1
            i = i + 1
        End If
        b = Dir
    Loop
    ListBox1.List = arr()
End Sub
Private Sub CommandButton1_Click()
    x = ListBox1.ListIndex
    If x = -1 Then
        MsgBox "Файл не выбран!"
    Else
        a = TextBox1.Value
        b = ListBox1.Value
        Workbooks.Open Filename:=a & b
        Range("C5:C25,E5:E25,G5:G25,I5:I25,K5:K25").Copy ThisWorkbook.Sheets("Лист1").Range("a3")
        Workbooks(b).Close False
        Unload UserForm1
    End If
End Sub
[/vba]

Автор - Nic70y
Дата добавления - 31.07.2023 в 09:38
stns Дата: Понедельник, 31.07.2023, 12:04 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 20% ±

Excel 2013
Nic70y, спасибо большое! Примерно понятно. Пытался сам это сделать, стопорится на ListBox1.List = arr(), пытаюсь скачать из вашего сообщения файл 1533819.xlsm, написано - такой страницы не существует. Нельзя ли продублировать.
 
Ответить
СообщениеNic70y, спасибо большое! Примерно понятно. Пытался сам это сделать, стопорится на ListBox1.List = arr(), пытаюсь скачать из вашего сообщения файл 1533819.xlsm, написано - такой страницы не существует. Нельзя ли продублировать.

Автор - stns
Дата добавления - 31.07.2023 в 12:04
Nic70y Дата: Понедельник, 31.07.2023, 12:09 | Сообщение № 5
Группа: Друзья
Ранг: Экселист
Сообщений: 8857
Репутация: 2308 ±
Замечаний: 0% ±

Excel 2010
stns, в файле 1533819.xlsm была недоработка, я его заменил на 8151144.xlsm,
скачайте его


ЮMoney 41001841029809
 
Ответить
Сообщениеstns, в файле 1533819.xlsm была недоработка, я его заменил на 8151144.xlsm,
скачайте его

Автор - Nic70y
Дата добавления - 31.07.2023 в 12:09
stns Дата: Понедельник, 31.07.2023, 12:53 | Сообщение № 6
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 20% ±

Excel 2013
Спасибо большое! Все отлично работает!
 
Ответить
СообщениеСпасибо большое! Все отлично работает!

Автор - stns
Дата добавления - 31.07.2023 в 12:53
  • Страница 1 из 1
  • 1
Поиск:

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