Всем доброго времени суток. В примере имеется книга учёта работы машин один месяц. В полной книге около 30 листов и на каждую машину отдельный лист. Используемый макрос CopyRows копирует строки по условию со всех листов, но в разные книги на первый лист. То есть после срабатывания макроса создаётcя для каждой копируемой строки отдельная книга. Мне нужно чтобы строки по выбранной дате со всей книги копировались на один лист(как в листе 3 в файле). Поиском ничего не нашёл. Спасибо за помощь.
Покажите где поправить. У меня не получается зациклить. Спасибо.
Скрытый текст
Код
Sub CopyRows()
Dim lRow As Long 'Counter
Dim lCol As Long 'Counter
Dim lCount As Long 'Counter
Dim rInputTable As Range 'The range being searched
Dim rTarget As Range 'The output table
Dim arInput() 'Array with input table
Dim arOutput() 'Array for output table
Dim vPattern As Variant 'Search criteria/pattern
On Error GoTo ErrorHandle
'Query the user for an exact identifier or a pattern
vPattern = InputBox("Идентификатор для копируемых строк" & vbNewLine _
& "Вы можете использовать подстановочные знаки для создания шаблонов:" & vbNewLine & vbNewLine _
& "? Любой одиночный символ" & vbNewLine _
& "* Ноль или больше символов" & vbNewLine _
& "# Любая цифра (0-9)" & vbNewLine _
& "[charlist] Любой символ в charlist" & vbNewLine _
& "[!charlist] Любой символ не в charlist", "Копирование строк")
'If the user clicked cancel or didn't write anything we exit
If Len(vPattern) = 0 Then Exit Sub
'You can define the input table as you like.
'In this case we use A1's current region.
'The "current region" is a range bounded by
'any combination of blank rows and blank columns.
'So if there are no blank columns or rows in the
'table, it is a convenient way to define the range.
Set rInputTable = Range("A9").CurrentRegion
Dim wsh As Worksheet
For Each wsh In ThisWorkbook.Worksheets
'Copy the table to the array arInput.
'The array will automatically get the
'same dimensions as the table.
'The reason for using an array is speed.
arInput = rInputTable.Value
'The table has been copied to the array, arInput,
'so we don't need the range anymore and set it to
'nothing to save memory.
Set rInputTable = Nothing
'Redimensions the output array to the same dimensions
'(rows and columns)as the input table. This will nearly
'always be bigger than necessary, but unless you have
'limited space for the output table, it doesn't matter,
'because we fill it from the top, and the last records
'will be empty rows.
'1 To UBound(arInput) is the number of rows, and
'1 To UBound(arInput, 2) is the number of columns
ReDim arOutput(1 To UBound(arInput), 1 To UBound(arInput, 2))
'Loop through the input array and copy records that
'match the search pattern to the output array.
For lRow = 1 To UBound(arInput)
'To compare we use the "Like" operator
'instead of "=". This allows the use of
'patterns/wildcards.
'The code assumes that the identifier
'is in the first column, but that can
'easily be changed. If you do so, you
'must be sure that the column exists,
'or you will get an error!
If arInput(lRow, 1) Like vPattern Then
'If there is a match, we increment
'the counter lCount and copy the
'row to the output array.
lCount = lCount + 1
'All cell values to the right of the
'first cell are copied. If you don't
'want all cell values copied, you must
'write a column number instead of
'UBound(arInput, 2)
For lCol = 1 To UBound(arInput, 2)
arOutput(lCount, lCol) = arInput(lRow, lCol)
Next
End If
Next
'If lCount is zero, there was no match
If lCount = 0 Then
MsgBox "No records matched your search criteria"
GoTo BeforeExit
End If
'In this example we add a new workbook and copy the
'output array to range A1 etc.
'Of course you can define another destination, e.g.
'a specific workbook or just another sheet.
Workbooks.Add
'Dimension the target table to the same size as the
'output array.
Set rTarget = Range("A1").Resize(UBound(arOutput), UBound(arOutput, 2))
'Copy the array to the range in one swift operation.
rTarget.Value = arOutput
BeforeExit:
On Error Resume Next
Set rTarget = Nothing
Erase arInput
Erase arOutput
Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure CopyRows"
Resume BeforeExit
Next wsh
End Sub
Вопрос, строки со всех листов нужно скопировать на один лист новой книги, или же в новой книге создаётся отдельный лист для каждого скопированного листа?
Код
Dim wsh As Worksheet
For Each wsh In ThisWorkbook.Worksheets
wsh.Activate
lCount = 0
Set rInputTable = Range("A9").CurrentRegion
......
rTarget.Value = arOutput
ThisWorkbook.Activate
Next wsh
Maruf написал: Вопрос, строки со всех листов нужно скопировать на один лист новой книги, или же в новой книге создаётся отдельный лист для каждого скопированного листа?
На один лист. И желательно не в новой книге, а в рабочей.
К сожалению цель не достигнута. Макрос копирует строки по условию с разных листов в разные книги. А мне нужно в одну книгу или на один лист этой книги. Должно получиться так:
ДАТА №п/л и т .д. 05.12.18 1234 05.12.18 3456 05.12.18 7890