Excel это не сложно
Добро пожаловать, Гость. Пожалуйста, войдите или зарегистрируйтесь.
16.04.2024, 23:27:44

Войти
Хотите поблагодарить участника за дельный совет? Нажмите [Повысить]. Так вы заслуженно поднимите репутацию активному участнику.
33 240 Сообщений в 5 456 Тем от 6 756 Пользователей
Последний пользователь: Expert2024
*
Перейти на сайт Хитрости Надстройка MulTEx Обучающие тренинги Наша группа ВКонтакте
Правила форума Начало Помощь Поиск Календарь Войти Регистрация Выйти
+  Excel это не сложно
|-+  Основные форумы
| |-+  Вопросы по Excel и VBA
| | |-+  макрос на копирование и вставку определенных строк в другую книгу
Страниц: [1] 2  Все   Вниз
« предыдущая тема следующая тема »
Печать
Автор Тема: макрос на копирование и вставку определенных строк в другую книгу  (Прочитано 12585 раз)
0 Пользователей и 1 Гость смотрят эту тему.
geba
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 21


Просмотр профиля
« : 15.12.2017, 17:37:01 »
Добрый вечер! Помогите пожалуйста с написанием макроса. Необходимо мне вот что сделать: есть файл №1, из него нужно скопировать строки с 56 по 68 (либо диапазон A56:FE68) и вставить эти данные в файл №2. Строки с 69 по 74 (либо диапазон A69:FE74) удалить в файле №2. После этого строки с 68 по 74 необходимо выровнять по высоте. Таких файлов более 500 штук, как открыть их все в папках я уже разобрался с вашей помощью, точнее мне очень помогли) код мне дали на вашем форуме и он меня выручил уже много раз! (Спасибо ещё раз за помощь!). Вот только как дополнить этот код необходимыми мне условиями не понимаю( Почитал форумы и статьи на просторах интернета, но похожего на мой случай не нашел. Подскажите если можно в каком хоть направление искать Обеспокоенный
Записан
sboy
Постоялец
***

Репутация: +27/-0
Офлайн Офлайн

Сообщений: 207


Просмотр профиля E-mail
« Ответ #1 : 18.12.2017, 10:10:04 »
Цитата: geba от 15.12.2017, 17:37:01
Таких файлов более 500 штук
Копировать из одного в 500?
или попарно как-то открывать?
Записан
geba
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 21


Просмотр профиля
« Ответ #2 : 18.12.2017, 10:17:43 »
Открывать по одному из 500(это разные отчёты, по одной форме) и копировать из образца в каждый
Пока у меня получилось только вот что:
Код: (vb) 
Option Explicit
 
Dim objFSO As Object, objFolder As Object, objFile As Object
Sub Пробный_Замена()
Dim sFolder As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
     Application.ScreenUpdating = False
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    GetSubFolders sFolder
    Set objFolder = Nothing
    Set objFSO = Nothing
    Application.ScreenUpdating = True
End Sub
Private Sub GetSubFolders(sPath)
    Dim sPathSeparator As String, sObjName As String
    Dim rf As Range
    Dim cell As Range
    
    Set objFolder = objFSO.GetFolder(sPath)
    For Each objFile In objFolder.Files
        If Replace(objFile.Name, objFSO.GetBaseName(objFile), "") Like ".xls*" Then
            'открываем книгу
            Workbooks.Open sPath & objFile.Name
            'действие с файлом
    Set rf = ActiveWorkbook.Rows("56:67").Select
    Selection.Copy
    Windows("îõðàíà_04_10.xls").Activate
    Range("A56:H56").Select
    ActiveSheet.Paste
    Rows("68:73").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    ActiveWorkbook.Close True
    End If
    Next
    For Each objFolder In objFolder.SubFolders
        GetSubFolders objFolder.Path & Application.PathSeparator
    Next
End Sub

но он не работает(
« Последнее редактирование: 18.12.2017, 11:04:53 от geba » Записан
geba
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 21


Просмотр профиля
« Ответ #3 : 18.12.2017, 11:49:45 »
Код: (vb) 
Option Explicit
 
Dim objFSO As Object, objFolder As Object, objFile As Object
Sub Ïðîáíûé_Çàìåíà()
Dim sFolder As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
     Application.ScreenUpdating = False
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    GetSubFolders sFolder
    Set objFolder = Nothing
    Set objFSO = Nothing
    Application.ScreenUpdating = True
End Sub
Private Sub GetSubFolders(sPath)
    Dim sPathSeparator As String, sObjName As String
    Dim rf As Range
    Dim cell As Range
    
    Set objFolder = objFSO.GetFolder(sPath)
    For Each objFile In objFolder.Files
        If Replace(objFile.Name, objFSO.GetBaseName(objFile), "") Like ".xls*" Then
            'îòêðûâàåì êíèãó
            ChDir "C:\Users\k.tyukov\Desktop\ìàêðîñ ïðîáíûé âàðèàíò\Îõð-çàù íîâàÿ ôîðìà"
            Workbooks.Open Filename:="09.03.2017 N 78.xls"
            'äåéñòâèÿ ñ ôàéëîì
    Rows("56:67").Select
    Selection.Copy
    Workbooks.Open sPath & objFile.Name
    Range("A56:H56").Select
    ActiveSheet.Paste
    Rows("68:73").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    ActiveWorkbook.Close True
    End If
    Next
    For Each objFolder In objFolder.SubFolders
        GetSubFolders objFolder.Path & Application.PathSeparator
    Next
End Sub

Вот это работает, но постоянно спрашивает "заметь содержимое конечных ячеек?", можно ли это как нибудь убрать? И ещё после выполнения всех операций не закрывает файл-образец, откуда копирует. не критично конечно, но если можно его тоже закрыть в конце всех действий, было бы неплохо.
Записан
Некто
Новичок
*

Репутация: +1/-0
Офлайн Офлайн

Сообщений: 7


Просмотр профиля E-mail
« Ответ #4 : 19.12.2017, 08:30:46 »
Цитата: geba от 18.12.2017, 11:49:45
спрашивает "заметь содержимое конечных ячеек?", можно ли это как нибудь убрать?
Привет!
перед вставкой
Код: (vb) 
Application.DisplayAlerts = 0

После вставки
Код: (vb) 
Application.DisplayAlerts = 1

Цитата: geba от 18.12.2017, 11:49:45
не закрывает файл-образец, откуда копирует
Объявите
Код: (vb) 
Dim wbTemp As Workbooks

после открытия нужной книги
Код: (vb) 
Set wbTemp = ActiveWorkbook

Для закрытия книги
Код: (vb) 
wbTemp.Close
Записан
geba
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 21


Просмотр профиля
« Ответ #5 : 19.12.2017, 09:27:20 »
Доброе утро. Спасибо большое, в первом случае всё понятно и всё работает! А вот со вторым чего-то не совсем понял. Куда именно нужно вставить
Код: (vb) 
Set wbTemp = ActiveWorkbook 
и
Код: (vb) 
wbTemp.Close

Я попробовал сделать как я понял, но он работать отказался. Если не сложно, выложи пожалуйста кусок кода в правильном виде.
Записан
Некто
Новичок
*

Репутация: +1/-0
Офлайн Офлайн

Сообщений: 7


Просмотр профиля E-mail
« Ответ #6 : 19.12.2017, 10:03:20 »
Код: (vb) 
Option Explicit

Dim objFSO As Object, objFolder As Object, objFile As Object
Sub I?iaiue_Caiaia()
    Dim sFolder As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    Application.ScreenUpdating = False
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    GetSubFolders sFolder
    Set objFolder = Nothing
    Set objFSO = Nothing
    Application.ScreenUpdating = True
End Sub
Private Sub GetSubFolders(sPath)
    Dim sPathSeparator As String, sObjName As String
    Dim rf As Range
    Dim cell As Range
    Dim wbTemp As Workbooks

    Set objFolder = objFSO.GetFolder(sPath)
    For Each objFile In objFolder.Files
        If Replace(objFile.Name, objFSO.GetBaseName(objFile), "") Like ".xls*" Then
    'ioe?uaaai eieao
            ChDir "C:\Users\k.tyukov\Desktop\iae?in i?iaiue aa?eaio\Io?-cau iiaay oi?ia"
            Workbooks.Open Filename:="09.03.2017 N 78.xls"
            Set wbTemp = ActiveWorkbook
    'aaenoaey n oaeeii
            Rows("56:67").Copy
            Workbooks.Open sPath & objFile.Name
            Range("A56:H56").Select
            Application.DisplayAlerts = 0
            ActiveSheet.Paste
            Application.DisplayAlerts = 1
            Application.CutCopyMode = False
            Rows("68:73").Delete Shift:=xlUp
            ActiveWorkbook.Close True
            wbTemp.Close wbTemp
        End If
    Next
    For Each objFolder In objFolder.SubFolders
        GetSubFolders objFolder.Path & Application.PathSeparator
    Next
End Sub
Записан
geba
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 21


Просмотр профиля
« Ответ #7 : 19.12.2017, 10:18:22 »
Так я и пробовал, не работает. Ругается на 30 строку.
Записан
Некто
Новичок
*

Репутация: +1/-0
Офлайн Офлайн

Сообщений: 7


Просмотр профиля E-mail
« Ответ #8 : 19.12.2017, 10:44:21 »
Цитата: geba от 19.12.2017, 10:18:22
Ругается на 30 строку.
Какими словами ругается?
Записан
geba
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 21


Просмотр профиля
« Ответ #9 : 19.12.2017, 11:10:59 »
Цитата: Некто от 19.12.2017, 10:44:21
Какими словами ругается?
Run-time error '13':
Type mismatch
Записан
sboy
Постоялец
***

Репутация: +27/-0
Офлайн Офлайн

Сообщений: 207


Просмотр профиля E-mail
« Ответ #10 : 19.12.2017, 11:14:11 »
Так у Вас же
Код: (vb) 
Option Explicit

Поэтому надо еще
Код: (vb) 
Dim wbTemp as Workbook
Записан
geba
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 21


Просмотр профиля
« Ответ #11 : 19.12.2017, 11:31:18 »
Код: (vb) 
Option Explicit
 
Dim objFSO As Object, objFolder As Object, objFile As Object
Sub Èçìåíåíèå_Ôîðìû_ÏîËåñàì_Îõðàíà()
Dim sFolder As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
     Application.ScreenUpdating = False
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    GetSubFolders sFolder
    Set objFolder = Nothing
    Set objFSO = Nothing
    Application.ScreenUpdating = True
End Sub
Private Sub GetSubFolders(sPath)
    Dim sPathSeparator As String, sObjName As String
    Dim rf As Range
    Dim cell As Range
    Dim wbTemp As Workbooks
    
    Set objFolder = objFSO.GetFolder(sPath)
    For Each objFile In objFolder.Files
        If Replace(objFile.Name, objFSO.GetBaseName(objFile), "") Like ".xls*" Then
            ChDir "C:\Users\k.tyukov\Desktop\ìàêðîñ ïðîáíûé âàðèàíò\Îõð-çàù íîâàÿ ôîðìà"
            Workbooks.Open Filename:="09.03.2017 N 78.xls"
            Set wbTemp = ActiveWorkbook
    Rows("56:67").Select
    Selection.Copy
    Workbooks.Open sPath & objFile.Name
    Range("A56:H56").Select
    Application.DisplayAlerts = 0
    ActiveSheet.Paste
    Application.DisplayAlerts = 1
    Rows("68:73").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    ActiveWorkbook.Close True
    wbTemp.Close wbTemp 'прошу обратить внимание на эту строку!
    End If
    Next
    For Each objFolder In objFolder.SubFolders
        GetSubFolders objFolder.Path & Application.PathSeparator
    Next
End Sub

Вот код который я пытаюсь выполнить, вроде всё так же... Может я слепой конечно)
Записан
geba
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 21


Просмотр профиля
« Ответ #12 : 19.12.2017, 11:35:08 »
 И ещё прошу обратить внимание на строку 41, если там прописано
Код: (vb) 
wbTemp.Close wbTemp

то вылетает ошибка: Compile error: Wrong number of arguments or invalid property assignment
А если так
Код: (vb) 
wbTemp.Close
, то ошибка которую я описывал выше.
Записан
Некто
Новичок
*

Репутация: +1/-0
Офлайн Офлайн

Сообщений: 7


Просмотр профиля E-mail
« Ответ #13 : 19.12.2017, 12:19:30 »
Пардон
Код: (vb) 
wbTemp.Close wbTemp 
это моя очепятка
Записан
sboy
Постоялец
***

Репутация: +27/-0
Офлайн Офлайн

Сообщений: 207


Просмотр профиля E-mail
« Ответ #14 : 19.12.2017, 13:39:05 »
Сравните, то что я написал в сообщении
Код: (vb) 
Dim wbTemp as Workbook

и то что Вы написали в коде
Код: (vb) 
Dim wbTemp As Workbooks
Записан
Страниц: [1] 2  Все   Вверх
Печать
« предыдущая тема следующая тема »
Перейти в:  

Powered by MySQL Powered by PHP Powered by SMF 1.1.21 | SMF © 2006-2011, Simple Machines Valid XHTML 1.0! Valid CSS!
Яндекс.Метрика Рейтинг@Mail.ru