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

Вход

Регистрация

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

 

= Мир MS Excel/Перенос диапазона строк в другой файл - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перенос диапазона строк в другой файл (Макросы/Sub)
Перенос диапазона строк в другой файл
AVI Дата: Понедельник, 19.09.2016, 12:48 | Сообщение № 1
Группа: Проверенные
Ранг: Ветеран
Сообщений: 523
Репутация: 17 ±
Замечаний: 0% ±

Excel 2016
Добрый день!
Пролистал весь форум, но не нашел то что нужно.
Необходимо, что бы из файла Output НЕПУСТЫЕ СТРОКИ из столбцов с С по L переносились в файл Input в диапазон с B по K в первую незаполненную строку. Диапазоны не меняются, а вот количество строк может быть до 1000.
Можно отдельно выделить часть макроса, который отвечает за отбор непустых ячеек. Хочу самостоятельно разобраться в нем.
Спасибо заранее.
К сообщению приложен файл: Output.xlsx (13.6 Kb) · Input.xlsx (8.8 Kb)


Сообщение отредактировал AVI - Понедельник, 19.09.2016, 13:00
 
Ответить
СообщениеДобрый день!
Пролистал весь форум, но не нашел то что нужно.
Необходимо, что бы из файла Output НЕПУСТЫЕ СТРОКИ из столбцов с С по L переносились в файл Input в диапазон с B по K в первую незаполненную строку. Диапазоны не меняются, а вот количество строк может быть до 1000.
Можно отдельно выделить часть макроса, который отвечает за отбор непустых ячеек. Хочу самостоятельно разобраться в нем.
Спасибо заранее.
Автор - AVI
Дата добавления - 19.09.2016 в 12:48
Manyasha Дата: Понедельник, 19.09.2016, 13:11 | Сообщение № 2
Группа: Модераторы
Ранг: Старожил
Сообщений: 2198
Репутация: 898 ±
Замечаний: 0% ±

Excel 2010, 2016
AVI, так подойдет?
[vba]
Код
Sub copyRows()
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    Dim shOutput As Worksheet, wbInput As Workbook, lr1 As Long, j As Long, i As Long
    Set shOutput = ThisWorkbook.Sheets(1)
    'ThisWorkbook.Path & "\Input.xlsx" -
    'путь к книге Input, если она лежит в этой же папке.
    'Если путь другой, заменить ThisWorkbook.Path & "\Input.xlsx" на полный путь
    Set wbInput = Workbooks.Open(ThisWorkbook.Path & "\Input.xlsx")
    
    lr1 = shOutput.Cells(Rows.Count, "c").End(xlUp).Row
    With wbInput.Sheets(1)
        j = .Cells(Rows.Count, "b").End(xlUp).Row + 1
        For i = 2 To lr1
            If shOutput.Cells(i, "c") <> "" Then
                .Cells(j, "b").Resize(, 10) = shOutput.Cells(i, "c").Resize(, 10).Value
                j = j + 1
            End If
        Next i
    End With
    wbInput.Close True
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With
End Sub
[/vba]
К сообщению приложен файл: Output-1.xlsm (22.4 Kb)

ЯД: 410013299366744 WM: R193491431804
 
Ответить
СообщениеAVI, так подойдет?
[vba]
Код
Sub copyRows()
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    Dim shOutput As Worksheet, wbInput As Workbook, lr1 As Long, j As Long, i As Long
    Set shOutput = ThisWorkbook.Sheets(1)
    'ThisWorkbook.Path & "\Input.xlsx" -
    'путь к книге Input, если она лежит в этой же папке.
    'Если путь другой, заменить ThisWorkbook.Path & "\Input.xlsx" на полный путь
    Set wbInput = Workbooks.Open(ThisWorkbook.Path & "\Input.xlsx")
    
    lr1 = shOutput.Cells(Rows.Count, "c").End(xlUp).Row
    With wbInput.Sheets(1)
        j = .Cells(Rows.Count, "b").End(xlUp).Row + 1
        For i = 2 To lr1
            If shOutput.Cells(i, "c") <> "" Then
                .Cells(j, "b").Resize(, 10) = shOutput.Cells(i, "c").Resize(, 10).Value
                j = j + 1
            End If
        Next i
    End With
    wbInput.Close True
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With
End Sub
[/vba]
Автор - Manyasha
Дата добавления - 19.09.2016 в 13:11
Szekerfehesvar Дата: Понедельник, 19.09.2016, 13:21 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 29
Репутация: 6 ±
Замечаний: 20% ±

Excel 2013
Или, как вариант:
[vba]
Код
Sub Macros()

    s = Cells(Rows.Count, 1).End(xlUp).Row
    ActiveSheet.Range("$A$1:$M$" & s).AutoFilter Field:=1, Criteria1:="<>"
    Range("C2:M" & s).Select
    Selection.Copy
    Windows("Input.xlsx").Activate
    Range("B" & Cells(Rows.Count, 2).End(xlUp).Row + 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Windows("Output.xlsx").Activate
    ActiveSheet.Range("$A$1:$M$" & s).AutoFilter Field:=1
End Sub
[/vba]

открытие книги Input не прописано)
отбор непустых строк идет обычной фильтрацией.
К сообщению приложен файл: Output2.xlsm (17.9 Kb)
 
Ответить
СообщениеИли, как вариант:
[vba]
Код
Sub Macros()

    s = Cells(Rows.Count, 1).End(xlUp).Row
    ActiveSheet.Range("$A$1:$M$" & s).AutoFilter Field:=1, Criteria1:="<>"
    Range("C2:M" & s).Select
    Selection.Copy
    Windows("Input.xlsx").Activate
    Range("B" & Cells(Rows.Count, 2).End(xlUp).Row + 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Windows("Output.xlsx").Activate
    ActiveSheet.Range("$A$1:$M$" & s).AutoFilter Field:=1
End Sub
[/vba]

открытие книги Input не прописано)
отбор непустых строк идет обычной фильтрацией.
Автор - Szekerfehesvar
Дата добавления - 19.09.2016 в 13:21
AVI Дата: Понедельник, 19.09.2016, 18:18 | Сообщение № 4
Группа: Проверенные
Ранг: Ветеран
Сообщений: 523
Репутация: 17 ±
Замечаний: 0% ±

Excel 2016
Manyasha, Идеально, спасибо
 
Ответить
СообщениеManyasha, Идеально, спасибо
Автор - AVI
Дата добавления - 19.09.2016 в 18:18
AVI Дата: Понедельник, 19.09.2016, 18:19 | Сообщение № 5
Группа: Проверенные
Ранг: Ветеран
Сообщений: 523
Репутация: 17 ±
Замечаний: 0% ±

Excel 2016
Szekerfehesvar, спасибо, но у Manyasha вариант то, что доктор прописал
 
Ответить
СообщениеSzekerfehesvar, спасибо, но у Manyasha вариант то, что доктор прописал
Автор - AVI
Дата добавления - 19.09.2016 в 18:19
AVI Дата: Вторник, 20.09.2016, 12:44 | Сообщение № 6
Группа: Проверенные
Ранг: Ветеран
Сообщений: 523
Репутация: 17 ±
Замечаний: 0% ±

Excel 2016
Manyasha,
[vba]
Код

Sub copyRows()
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    Dim shOutput As Worksheet, wbInput As Workbook, lr1 As Long, j As Long, i As Long
    Set shOutput = ThisWorkbook.Sheets("Итог")
    'ThisWorkbook.Path & "\Input.xlsx" -
    'путь к книге Input, если она лежит в этой же папке.
    'Если путь другой, заменить ThisWorkbook.Path & "\Input.xlsx" на полный путь
    Set wbInput = Workbooks.Open(ThisWorkbook.Path & "\Обработано.xlsx")
    
    lr1 = shOutput.Cells(Rows.Count, "c").End(xlUp).Row
    With wbInput.Sheets(1)
        j = .Cells(Rows.Count, "b").End(xlUp).Row + 1
        For i = 2 To lr1
            If shOutput.Cells(i, "c") <> "" Then
                .Cells(j, "b").Resize(, 10) = shOutput.Cells(i, "c").Resize(, 10).Value
                j = j + 1
            End If
        Next i
    End With
    wbInput.Close True
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With
End Sub
[/vba]
Сменил имя листа на [vba]
Код
ThisWorkbook.Sheets("Итог")
[/vba]
и сразу вылезает ошибка [vba]
Код
If shOutput.Cells(i, "c") <> "" Then
[/vba]
Помогите, пожалуйста.

Сама ошибка Run-time error '13': Type mismatch


Сообщение отредактировал AVI - Вторник, 20.09.2016, 12:52
 
Ответить
СообщениеManyasha,
[vba]
Код

Sub copyRows()
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    Dim shOutput As Worksheet, wbInput As Workbook, lr1 As Long, j As Long, i As Long
    Set shOutput = ThisWorkbook.Sheets("Итог")
    'ThisWorkbook.Path & "\Input.xlsx" -
    'путь к книге Input, если она лежит в этой же папке.
    'Если путь другой, заменить ThisWorkbook.Path & "\Input.xlsx" на полный путь
    Set wbInput = Workbooks.Open(ThisWorkbook.Path & "\Обработано.xlsx")
    
    lr1 = shOutput.Cells(Rows.Count, "c").End(xlUp).Row
    With wbInput.Sheets(1)
        j = .Cells(Rows.Count, "b").End(xlUp).Row + 1
        For i = 2 To lr1
            If shOutput.Cells(i, "c") <> "" Then
                .Cells(j, "b").Resize(, 10) = shOutput.Cells(i, "c").Resize(, 10).Value
                j = j + 1
            End If
        Next i
    End With
    wbInput.Close True
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With
End Sub
[/vba]
Сменил имя листа на [vba]
Код
ThisWorkbook.Sheets("Итог")
[/vba]
и сразу вылезает ошибка [vba]
Код
If shOutput.Cells(i, "c") <> "" Then
[/vba]
Помогите, пожалуйста.

Сама ошибка Run-time error '13': Type mismatch
Автор - AVI
Дата добавления - 20.09.2016 в 12:44
Manyasha Дата: Вторник, 20.09.2016, 12:54 | Сообщение № 7
Группа: Модераторы
Ранг: Старожил
Сообщений: 2198
Репутация: 898 ±
Замечаний: 0% ±

Excel 2010, 2016
AVI, показывайте в файле.

ЯД: 410013299366744 WM: R193491431804
 
Ответить
СообщениеAVI, показывайте в файле.
Автор - Manyasha
Дата добавления - 20.09.2016 в 12:54
AVI Дата: Среда, 21.09.2016, 07:29 | Сообщение № 8
Группа: Проверенные
Ранг: Ветеран
Сообщений: 523
Репутация: 17 ±
Замечаний: 0% ±

Excel 2016
Manyasha,
Архивы можно грузить?
К сообщению приложен файл: Desktop.7z (75.1 Kb)


Сообщение отредактировал AVI - Среда, 21.09.2016, 07:30
 
Ответить
СообщениеManyasha,
Архивы можно грузить?
Автор - AVI
Дата добавления - 21.09.2016 в 07:29
Manyasha Дата: Среда, 21.09.2016, 10:59 | Сообщение № 9
Группа: Модераторы
Ранг: Старожил
Сообщений: 2198
Репутация: 898 ±
Замечаний: 0% ±

Excel 2010, 2016
AVI, смотрите строки 90 и далее на листе Итог, есть ошибки #Ссылка! Добавьте проверку на ошибки перед копированием:
[vba]
Код
            If WorksheetFunction.IfError(shOutput.Cells(i, "c"), "") <> "" Then
                .Cells(j, "b").Resize(, 10) = shOutput.Cells(i, "c").Resize(, 10).Value
                j = j + 1
            End If
[/vba]

ЯД: 410013299366744 WM: R193491431804
 
Ответить
СообщениеAVI, смотрите строки 90 и далее на листе Итог, есть ошибки #Ссылка! Добавьте проверку на ошибки перед копированием:
[vba]
Код
            If WorksheetFunction.IfError(shOutput.Cells(i, "c"), "") <> "" Then
                .Cells(j, "b").Resize(, 10) = shOutput.Cells(i, "c").Resize(, 10).Value
                j = j + 1
            End If
[/vba]
Автор - Manyasha
Дата добавления - 21.09.2016 в 10:59
AVI Дата: Среда, 21.09.2016, 11:05 | Сообщение № 10
Группа: Проверенные
Ранг: Ветеран
Сообщений: 523
Репутация: 17 ±
Замечаний: 0% ±

Excel 2016
Manyasha, Я заметил, что при удалении ячеек с ошибками скрипт срабатывает без ошибок, но сам исправить не смог. Спасибо!
 
Ответить
СообщениеManyasha, Я заметил, что при удалении ячеек с ошибками скрипт срабатывает без ошибок, но сам исправить не смог. Спасибо!
Автор - AVI
Дата добавления - 21.09.2016 в 11:05
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перенос диапазона строк в другой файл (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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