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

Вход

Регистрация

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

 

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

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

Excel 2013
Нужна помощь, никак не справиться.
Необходимо копировать новые номера заказов и суммы в файл учет 2 в столбцы 4 и 5, чтобы все по порядку шло. Условие, что в файле учет находит слово в столбце 4,
находим все ячейки с этим словом, и нужно скопировать в книгу учет 2 ячейки находящиеся левее на две от найденых и на одну правее.
но номера не должны повторяться.
Никак не получается, цикл все проверяет и копирует все

[vba]
Код
Sub example2()
Dim x As Range
Dim wb0 As Workbook
Dim wl0 As Worksheet
Application.ScreenUpdating = False
Set wb0 = ThisWorkbook
Set wl0 = wb0.ActiveSheet
wb0.Activate

Workbooks.Open Filename:="C:\Учет .xlsx"

For Each x In wl0.UsedRange.Cells
If LCase(x.Value) Like "*окна*" Then

With Application.Workbooks.Item("Учет.xlsx")

rk = Workbooks("Учет.xlsx").Worksheets("Лист1").Cells(Rows.Count, 3).End(xlUp).Row

If Not Columns("C:C").Find(what:=x.Offset(, -2), lookat:=xlWhole) Is Nothing Then

Sheets("Лист1").Cells(rk + 1, 3).Value = x.Offset(, -2)

End If
Next i

End With
End If

Next x

'Workbooks("Учет.xlsx").Close SaveChanges:=True

End Sub
[/vba]
К сообщению приложен файл: 2032913.xlsx(9Kb) · 6139046.xlsx(53Kb)


Сообщение отредактировал kleo90 - Среда, 11.05.2016, 11:24
 
Ответить
СообщениеНужна помощь, никак не справиться.
Необходимо копировать новые номера заказов и суммы в файл учет 2 в столбцы 4 и 5, чтобы все по порядку шло. Условие, что в файле учет находит слово в столбце 4,
находим все ячейки с этим словом, и нужно скопировать в книгу учет 2 ячейки находящиеся левее на две от найденых и на одну правее.
но номера не должны повторяться.
Никак не получается, цикл все проверяет и копирует все

[vba]
Код
Sub example2()
Dim x As Range
Dim wb0 As Workbook
Dim wl0 As Worksheet
Application.ScreenUpdating = False
Set wb0 = ThisWorkbook
Set wl0 = wb0.ActiveSheet
wb0.Activate

Workbooks.Open Filename:="C:\Учет .xlsx"

For Each x In wl0.UsedRange.Cells
If LCase(x.Value) Like "*окна*" Then

With Application.Workbooks.Item("Учет.xlsx")

rk = Workbooks("Учет.xlsx").Worksheets("Лист1").Cells(Rows.Count, 3).End(xlUp).Row

If Not Columns("C:C").Find(what:=x.Offset(, -2), lookat:=xlWhole) Is Nothing Then

Sheets("Лист1").Cells(rk + 1, 3).Value = x.Offset(, -2)

End If
Next i

End With
End If

Next x

'Workbooks("Учет.xlsx").Close SaveChanges:=True

End Sub
[/vba]

Автор - kleo90
Дата добавления - 11.05.2016 в 10:48
китин Дата: Среда, 11.05.2016, 11:10 | Сообщение № 2
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3423
Репутация: 543 ±
Замечаний: 0% ±

Excel 2007;Excel 2010
формулы и коды надо сувать в теги.выделяете код и нажимаете кнопочку #


Не судите строго:я пытаюсь научиться
ЯД 41001877306852/WM R249698041931; Z239672726538
 
Ответить
Сообщениеформулы и коды надо сувать в теги.выделяете код и нажимаете кнопочку #

Автор - китин
Дата добавления - 11.05.2016 в 11:10
KuklP Дата: Среда, 11.05.2016, 12:24 | Сообщение № 3
Группа: Проверенные
Ранг: Старожил
Сообщений: 1998
Репутация: 436 ±
Замечаний: 0% ±

Файл не смотрел, но судя по описанию вот так:
[vba]
Код
If Columns(3).Find(what:=x.Offset(, -2), lookat:=xlWhole) Is Nothing Then
[/vba] и т. д. :)


Ну, с НДС и мы чего-то стoим! kuklp@mail.ru
WM Z206653985942, R334086032478, U238399322728
 
Ответить
СообщениеФайл не смотрел, но судя по описанию вот так:
[vba]
Код
If Columns(3).Find(what:=x.Offset(, -2), lookat:=xlWhole) Is Nothing Then
[/vba] и т. д. :)

Автор - KuklP
Дата добавления - 11.05.2016 в 12:24
KuklP Дата: Среда, 11.05.2016, 12:36 | Сообщение № 4
Группа: Проверенные
Ранг: Старожил
Сообщений: 1998
Репутация: 436 ±
Замечаний: 0% ±

Что-то у Вас там сплошной косяк. nextы лишние, точек не хватает и т.д. Файл так и не открывал, но попробуйте:
[vba]
Код
Sub example2()
    Dim x As Range
    Dim wb0 As Workbook
    Dim wl0 As Worksheet
    Application.ScreenUpdating = False
    Set wb0 = ThisWorkbook
    Set wl0 = wb0.ActiveSheet
    wb0.Activate
    With Workbooks.Open("C:\Учет .xlsx")
        For Each x In wl0.UsedRange.Cells
            If LCase(x.Value) Like "*окна*" Then
                rk = .Worksheets("Лист1").Cells(Rows.Count, 3).End(xlUp).Row
                If Not .Worksheets("Лист1").Columns(3).Find(x.Offset(, -2), , , 1) Is Nothing Then
                    .Worksheets("Лист1").Cells(rk + 1, 3).Value = x.Offset(, -2)
                End If
            End If
        Next x
'.Close True
    End With   
End Sub
[/vba]


Ну, с НДС и мы чего-то стoим! kuklp@mail.ru
WM Z206653985942, R334086032478, U238399322728


Сообщение отредактировал KuklP - Среда, 11.05.2016, 12:38
 
Ответить
СообщениеЧто-то у Вас там сплошной косяк. nextы лишние, точек не хватает и т.д. Файл так и не открывал, но попробуйте:
[vba]
Код
Sub example2()
    Dim x As Range
    Dim wb0 As Workbook
    Dim wl0 As Worksheet
    Application.ScreenUpdating = False
    Set wb0 = ThisWorkbook
    Set wl0 = wb0.ActiveSheet
    wb0.Activate
    With Workbooks.Open("C:\Учет .xlsx")
        For Each x In wl0.UsedRange.Cells
            If LCase(x.Value) Like "*окна*" Then
                rk = .Worksheets("Лист1").Cells(Rows.Count, 3).End(xlUp).Row
                If Not .Worksheets("Лист1").Columns(3).Find(x.Offset(, -2), , , 1) Is Nothing Then
                    .Worksheets("Лист1").Cells(rk + 1, 3).Value = x.Offset(, -2)
                End If
            End If
        Next x
'.Close True
    End With   
End Sub
[/vba]

Автор - KuklP
Дата добавления - 11.05.2016 в 12:36
kleo90 Дата: Среда, 11.05.2016, 12:53 | Сообщение № 5
Группа: Пользователи
Ранг: Новичок
Сообщений: 11
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Спасибо огромное, все поправила, работает))
 
Ответить
СообщениеСпасибо огромное, все поправила, работает))

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

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