Копирование данных в другую книгу, если условие/критерий удовлетворены

извините, если это было задано здесь много раз. Я новичок в VBA Excel, поэтому у меня есть только краткое представление о том, как начать код. Я использую Эксель 2013.

У меня есть 2 разные книги, основная и копия. Строки с 1 по 4 будут пустыми. Строка 5 предназначена для заголовка/маркировки информации, которую она будет предоставлять для обеих книг.

«Основная» рабочая книга будет использовать столбцы от A до DN для хранения всех данных.

Если ячейка содержит "X" - она ​​скопирует столбец A в P, в книгу "копировать". После чего он перейдет к следующей строке, чтобы определить то же самое. Если ячейка пуста, она перейдет к следующей строке, чтобы определить то же самое. Код должен быть динамическим, так как каждые 3 месяца будет добавляться новая информация, например добавление новых строк или изменение критериев с «X» на «пусто» или «пусто» на «X».

Это код, который у меня есть на данный момент. Это работает, но поскольку нужно проверить так много столбцов, мне посоветовали сделать для этого другой код.

Sub copy()
Dim lr As Long, lr2 As Long, r As Long
lr = Sheets("main").Cells(Rows.Count, "A").End(xlUp).row
lr2 = Sheets("copy").Cells(Rows.Count, "A").End(xlUp).row
For r = lr To 2 Step -1
    If range("Q" & r).Value = "X" Then
        Rows(r).copy Destination:=Sheets("copy").range("A" & lr2 + 1)
        lr2 = Sheets("copy").Cells(Rows.Count, "A").End(xlUp).row
    End If
Next r
End Sub


excel vba
person miester516    schedule 14.07.2017    source источник
comment
Приведенный выше код предназначен для копирования на другой лист. Но мне нужно будет перенести его в другую книгу на данный момент. Заранее большое спасибо!!   -  person miester516    schedule 14.07.2017
comment
Извините, если я вас неправильно понимаю, но почему бы вам просто не отфильтровать данные, а не перебирать данные? Отфильтруйте данные, если они соответствуют вашему критерию, а затем вставьте на новый лист, если sh.range(A1000000).end(xlup).row ‹› 1   -  person Lowpar    schedule 14.07.2017

Ответы (1)


arrow_upward
1
arrow_downward

Для этого вам нужно будет объявить две переменные рабочей книги и две переменные рабочего листа для хранения исходной и целевой рабочих книг и ссылок на рабочие листы в коде.

Настройте следующий код в соответствии с вашими требованиями.

Я добавил комментарии в код, которые помогут вам понять ход программы.

Кроме того, можно использовать дополнительную обработку ошибок, чтобы убедиться, что исходный и целевой листы находятся в исходной и целевой книге соответственно. При необходимости вы также можете добавить обработку ошибок.

Option Explicit

Sub CopyDatoToAnotherWorkbook()
Dim srcWB As Workbook, destWB As Workbook       'Variables to hold the source and destination workbook
Dim srcWS As Worksheet, destWS As Worksheet     'Variables to hold the source and destination worksheets
Dim FilePath As String                          'Variable to hold the full path of the destination workbook including it's name with extension
Dim lr As Long, lr2 As Long, r As Long

Application.ScreenUpdating = False

Set srcWB = ThisWorkbook                        'Setting the source workbook
Set srcWS = srcWB.Sheets("main")                'Setting the source worksheet

'Setting the FilePath of the destination workbook
'The below line assumes that the destination file's name is MyFile.xlsx and it is saved at your desktop. Change the path as per your requirement
FilePath = Environ("UserProfile") & "\Desktop\MyFile.xlsx"

'Cheching if the destination file exists, it yes, proceed with the code else EXIT
If Dir(FilePath) = "" Then
    MsgBox "The file   " & FilePath & "   doesn't exist!", vbCritical, "File Not Found!"
    Exit Sub
End If
'Finding the last row used in column A on source worksheet
lr = srcWS.Cells(Rows.Count, "A").End(xlUp).Row

'Opening the destination workbook and setting the source workbook
Set destWB = Workbooks.Open(FilePath)

'Setting the destination worksheet
Set destWS = destWB.Sheets("copy")

'Looping through rows on source worksheets
For r = lr To 2 Step -1
    'Finding the first empty row in column A on destination worksheet
    lr2 = destWS.Cells(Rows.Count, "A").End(xlUp).Row + 1

    If srcWS.Range("Q" & r).Value = "X" Then
        srcWS.Rows(r).copy Destination:=destWS.Range("A" & lr2 + 1)
    End If
Next r

'Closing the destination workbook
destWB.Close True
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
person Subodh Tiwari sktneer    schedule 14.07.2017