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

Вход

Регистрация

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

 

= Мир MS Excel/Перенос строк одной книги в другую - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перенос строк одной книги в другую (Макросы/Sub)
Перенос строк одной книги в другую
w00t Дата: Среда, 17.08.2016, 17:29 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 126
Репутация: 3 ±
Замечаний: 0% ±

Исходно: две книги.

Из многих листов интересуют листы с определенным наименованием, штук 10 листов. В этих листах заранее известны нужные номера строк. например, строки 3,9,70. Строки одинаковы для нужных листов.

Строки 3,9,70 листа "Тест" первого заполненного файла перенести в соответствующие 3,9,70 строки листа "Тест" второго заполненого файла.
Далее, строки 3,9,70 листа "Данные" первого файла перенессти в соответствующие строки листа "Данные" второго файла.

Строки перенсти полностью (entire row) и вставить как формулы.

Если бы не большие объемы - можно сделать вручную. Но объемы не маленькие( Вручную запарно будет копировать 150 строк определенных одного листа в другой такой же лист второго файла, перезаписывая данные. И так для всех нужных листов.. Один раз бы задать:
* какие номера строк
* с каких листов первого файла
* перезаписать соответствующие строки соответствущих по наименованиям листов второго файла.
К сообщению приложен файл: 5724302.xlsx(10Kb)


Сообщение отредактировал w00t - Среда, 17.08.2016, 17:33
 
Ответить
СообщениеИсходно: две книги.

Из многих листов интересуют листы с определенным наименованием, штук 10 листов. В этих листах заранее известны нужные номера строк. например, строки 3,9,70. Строки одинаковы для нужных листов.

Строки 3,9,70 листа "Тест" первого заполненного файла перенести в соответствующие 3,9,70 строки листа "Тест" второго заполненого файла.
Далее, строки 3,9,70 листа "Данные" первого файла перенессти в соответствующие строки листа "Данные" второго файла.

Строки перенсти полностью (entire row) и вставить как формулы.

Если бы не большие объемы - можно сделать вручную. Но объемы не маленькие( Вручную запарно будет копировать 150 строк определенных одного листа в другой такой же лист второго файла, перезаписывая данные. И так для всех нужных листов.. Один раз бы задать:
* какие номера строк
* с каких листов первого файла
* перезаписать соответствующие строки соответствущих по наименованиям листов второго файла.

Автор - w00t
Дата добавления - 17.08.2016 в 17:29
Udik Дата: Среда, 17.08.2016, 18:56 | Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 1215
Репутация: 153 ±
Замечаний: 0% ±

Excel 2013
Вот основа, насколько понял
[vba]
Код

Option Explicit

Public Sub copyData()
Dim w1 As Workbook
Dim str1 As String
Dim arrSheet, arrRow
Dim i As Integer, j%

arrSheet = Array("Тест", "Тест2") 'список листов
arrRow = Array(3, 9, 20) 'список номеров строк
str1 = ThisWorkbook.Path & "\out.xlsx" 'имя файла вывода, файл должен существовать
Set w1 = Workbooks.Open(str1)
ThisWorkbook.Activate

For i = 0 To UBound(arrRow)
For j = 0 To UBound(arrSheet)
ThisWorkbook.Worksheets(arrSheet(j)).Activate
Range(Cells(arrRow(i), 1), Cells(arrRow(i), 200)).Copy Destination:=w1.Worksheets(arrSheet(j)).Cells(arrRow(i), 1)
Next j
Next i
w1.Save
w1.Close
End Sub

[/vba]
К сообщению приложен файл: 0t0.xlsm(19Kb)


вот вам барабан
яд 41001231307558 wm R419131876897
udik1968@gmail.com
 
Ответить
СообщениеВот основа, насколько понял
[vba]
Код

Option Explicit

Public Sub copyData()
Dim w1 As Workbook
Dim str1 As String
Dim arrSheet, arrRow
Dim i As Integer, j%

arrSheet = Array("Тест", "Тест2") 'список листов
arrRow = Array(3, 9, 20) 'список номеров строк
str1 = ThisWorkbook.Path & "\out.xlsx" 'имя файла вывода, файл должен существовать
Set w1 = Workbooks.Open(str1)
ThisWorkbook.Activate

For i = 0 To UBound(arrRow)
For j = 0 To UBound(arrSheet)
ThisWorkbook.Worksheets(arrSheet(j)).Activate
Range(Cells(arrRow(i), 1), Cells(arrRow(i), 200)).Copy Destination:=w1.Worksheets(arrSheet(j)).Cells(arrRow(i), 1)
Next j
Next i
w1.Save
w1.Close
End Sub

[/vba]

Автор - Udik
Дата добавления - 17.08.2016 в 18:56
w00t Дата: Среда, 17.08.2016, 19:39 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 126
Репутация: 3 ±
Замечаний: 0% ±

Почему-то подсвечивает от эту строку

[vba]
Код
Range(Cells(arrRow(i), 1), Cells(arrRow(i), 200)).Copy Destination:=w1.Worksheets(arrSheet(j)).Cells(arrRow(i), 1)
[/vba]

пишет subscript out of range. В качестве вывода указал файл с первого поста. То есть источник - файл ваш. Из него данные в файл из первого поста, соответственно, к которому путь и указал локально на ПК.

Попутно маленький вопрос. Как правильно сделать цикл, чтобы повторить эту процедуру для всех файлов в определенной папке. В примере это ThisWorkbook.Path (можно и в нем, только тогда 0t0.xlsm бы исключить из которого растиражирование на все другие фалы в папке произойдет...)
 
Ответить
СообщениеПочему-то подсвечивает от эту строку

[vba]
Код
Range(Cells(arrRow(i), 1), Cells(arrRow(i), 200)).Copy Destination:=w1.Worksheets(arrSheet(j)).Cells(arrRow(i), 1)
[/vba]

пишет subscript out of range. В качестве вывода указал файл с первого поста. То есть источник - файл ваш. Из него данные в файл из первого поста, соответственно, к которому путь и указал локально на ПК.

Попутно маленький вопрос. Как правильно сделать цикл, чтобы повторить эту процедуру для всех файлов в определенной папке. В примере это ThisWorkbook.Path (можно и в нем, только тогда 0t0.xlsm бы исключить из которого растиражирование на все другие фалы в папке произойдет...)

Автор - w00t
Дата добавления - 17.08.2016 в 19:39
w00t Дата: Среда, 17.08.2016, 22:50 | Сообщение № 4
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 126
Репутация: 3 ±
Замечаний: 0% ±

Немного разобрался, но не до конца. Этот костяк отлично работает.

Понял, почему ошибка была. В книге-приемнике небыло листа, точно совпадающего с листом книги-источника по наименованию.

Пример: в источнике листы называются: "Тест", "Тест2", "Тест3", "Тест4"
В приемнике "Тест", "Тест2", "Тест3"

То есть, здесь конфликт (в приемнике нет листа Тест4). Можете помочь подправить, чтобы в таком случае, данные с источника, с листов наименованиями "Тест", "Тест2", "Тест3" скопированы в соответствующие листы приемника? А раз один лист в приемнике не совпал с источником, то вывести сообщение?

И правильно ли,если цикл?

[vba]
Код
Sub ProcessFiles()

    Dim Filename, Pathname As String
    Dim w1 As Workbook
    Dim w2 As Workbook
    
    Dim str1 As String
    Dim arrSheet, arrRow
    Dim i As Integer, j%
    
    Set w1 = ActiveWorkbook

    arrSheet = Array("Тест", "Тест2")
    arrRow = Array(3, 9, 20)

    Pathname = ActiveWorkbook.Path & "\"
    Filename = Dir(Pathname & "*.xlsx")
    Do While Filename <> ""
        Set w1 = Workbooks.Open(Pathname & Filename)
        ThisWorkbook.Activate
        For i = 0 To UBound(arrRow)
        For j = 0 To UBound(arrSheet)
        ThisWorkbook.Worksheets(arrSheet(j)).Activate
        Range(Cells(arrRow(i), 1), Cells(arrRow(i), 200)).Copy Destination:=w1.Worksheets(arrSheet(j)).Cells(arrRow(i), 1)
        Next j
        Next i
        w1.Save
        w1.Close
        Filename = Dir()
    Loop
End Sub
[/vba]
К сообщению приложен файл: 7039619.xlsm(17Kb)


Сообщение отредактировал w00t - Четверг, 18.08.2016, 00:41
 
Ответить
СообщениеНемного разобрался, но не до конца. Этот костяк отлично работает.

Понял, почему ошибка была. В книге-приемнике небыло листа, точно совпадающего с листом книги-источника по наименованию.

Пример: в источнике листы называются: "Тест", "Тест2", "Тест3", "Тест4"
В приемнике "Тест", "Тест2", "Тест3"

То есть, здесь конфликт (в приемнике нет листа Тест4). Можете помочь подправить, чтобы в таком случае, данные с источника, с листов наименованиями "Тест", "Тест2", "Тест3" скопированы в соответствующие листы приемника? А раз один лист в приемнике не совпал с источником, то вывести сообщение?

И правильно ли,если цикл?

[vba]
Код
Sub ProcessFiles()

    Dim Filename, Pathname As String
    Dim w1 As Workbook
    Dim w2 As Workbook
    
    Dim str1 As String
    Dim arrSheet, arrRow
    Dim i As Integer, j%
    
    Set w1 = ActiveWorkbook

    arrSheet = Array("Тест", "Тест2")
    arrRow = Array(3, 9, 20)

    Pathname = ActiveWorkbook.Path & "\"
    Filename = Dir(Pathname & "*.xlsx")
    Do While Filename <> ""
        Set w1 = Workbooks.Open(Pathname & Filename)
        ThisWorkbook.Activate
        For i = 0 To UBound(arrRow)
        For j = 0 To UBound(arrSheet)
        ThisWorkbook.Worksheets(arrSheet(j)).Activate
        Range(Cells(arrRow(i), 1), Cells(arrRow(i), 200)).Copy Destination:=w1.Worksheets(arrSheet(j)).Cells(arrRow(i), 1)
        Next j
        Next i
        w1.Save
        w1.Close
        Filename = Dir()
    Loop
End Sub
[/vba]

Автор - w00t
Дата добавления - 17.08.2016 в 22:50
nilem Дата: Четверг, 18.08.2016, 07:08 | Сообщение № 5
Группа: Авторы
Ранг: Ветеран
Сообщений: 1057
Репутация: 400 ±
Замечаний: 0% ±

Excel 2013
Наверное, как-то вот так вот:


Яндекс.Деньги 4100159601573
 
Ответить
СообщениеНаверное, как-то вот так вот:

Автор - nilem
Дата добавления - 18.08.2016 в 07:08
Udik Дата: Четверг, 18.08.2016, 13:43 | Сообщение № 6
Группа: Друзья
Ранг: Старожил
Сообщений: 1215
Репутация: 153 ±
Замечаний: 0% ±

Excel 2013
чтобы в таком случае, данные с источника, с листов наименованиями "Тест", "Тест2", "Тест3" скопированы в соответствующие листы приемника? А раз один лист в приемнике не совпал с источником, то вывести сообщение?

добавил код
[vba]
Код

Option Explicit

Public Sub copyData()
    Dim w1 As Workbook
    Dim str1 As String
    Dim arrSheet, arrRow
    Dim i As Integer, j%
    Dim oDict
    
    arrSheet = Array("Тест", "Тест4", "Тест2") 'список листов
    arrRow = Array(3, 9, 20) 'список номеров строк
    str1 = ThisWorkbook.Path & "\out.xlsx" 'имя файла вывода
    Set w1 = Workbooks.Open(str1)
    ThisWorkbook.Activate
    Set oDict = CreateObject("Scripting.Dictionary")
    oDict.CompareMode = 1
    For i = 0 To UBound(arrRow)
        For j = 0 To UBound(arrSheet)
            str1 = arrSheet(j)
            If SheetExists(str1, w1) Then
            ThisWorkbook.Worksheets(arrSheet(j)).Activate
            Range(Cells(arrRow(i), 1), Cells(arrRow(i), 200)).Copy Destination:=w1.Worksheets(arrSheet(j)).Cells(arrRow(i), 1)
            Else
            If Not oDict.exists(str1) Then
            oDict.Add str1, 1
            MsgBox "В целевом файле отсутствует лист: " & str1, 48, "Отсутствие листа"
            End If
            End If
        Next j
    Next i
    w1.Save
    w1.Close
    Set oDict = Nothing
End Sub

Function SheetExists(SheetName As String, wb As Workbook) As Boolean
On Error Resume Next
SheetExists = Not wb.Sheets(SheetName) Is Nothing
End Function

[/vba]
К сообщению приложен файл: 4986306.xlsm(21Kb)


вот вам барабан
яд 41001231307558 wm R419131876897
udik1968@gmail.com
 
Ответить
Сообщение
чтобы в таком случае, данные с источника, с листов наименованиями "Тест", "Тест2", "Тест3" скопированы в соответствующие листы приемника? А раз один лист в приемнике не совпал с источником, то вывести сообщение?

добавил код
[vba]
Код

Option Explicit

Public Sub copyData()
    Dim w1 As Workbook
    Dim str1 As String
    Dim arrSheet, arrRow
    Dim i As Integer, j%
    Dim oDict
    
    arrSheet = Array("Тест", "Тест4", "Тест2") 'список листов
    arrRow = Array(3, 9, 20) 'список номеров строк
    str1 = ThisWorkbook.Path & "\out.xlsx" 'имя файла вывода
    Set w1 = Workbooks.Open(str1)
    ThisWorkbook.Activate
    Set oDict = CreateObject("Scripting.Dictionary")
    oDict.CompareMode = 1
    For i = 0 To UBound(arrRow)
        For j = 0 To UBound(arrSheet)
            str1 = arrSheet(j)
            If SheetExists(str1, w1) Then
            ThisWorkbook.Worksheets(arrSheet(j)).Activate
            Range(Cells(arrRow(i), 1), Cells(arrRow(i), 200)).Copy Destination:=w1.Worksheets(arrSheet(j)).Cells(arrRow(i), 1)
            Else
            If Not oDict.exists(str1) Then
            oDict.Add str1, 1
            MsgBox "В целевом файле отсутствует лист: " & str1, 48, "Отсутствие листа"
            End If
            End If
        Next j
    Next i
    w1.Save
    w1.Close
    Set oDict = Nothing
End Sub

Function SheetExists(SheetName As String, wb As Workbook) As Boolean
On Error Resume Next
SheetExists = Not wb.Sheets(SheetName) Is Nothing
End Function

[/vba]

Автор - Udik
Дата добавления - 18.08.2016 в 13:43
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перенос строк одной книги в другую (Макросы/Sub)
Страница 1 из 11
Поиск:

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