Задача есть 2 файла. Первый файл с ежедневным пополнением строк, второй файл из первого по определенным параметрам необходимо подтянуть данные. В первом файле они должны удалиться во втором накопиться в конце. Создал макрос с циклом где одна строка копируется вставляется удаляется. но макрос работает довольно таки долго. Попробовал с массивами. Но не могу сообразить как вставлять в последнюю строку и удалять из первого файла строку можно ли это сделать? В массиве ниже данные подтягиваются, но затирают все строки сверху во втором файле и не удаляются.
Код
Sub df()
Dim SRow As Long
Dim NRow As Long
Dim Data_Otgr As String
Dim ish
Dim kon
Data_Otgr = nameOper
With Workbooks(moz).Sheets(qq)
ish = .Range(.[A4], .Cells(.UsedRange.Rows.Count, "R")).Value
End With
ReDim kon(1 To UBound(ish), 1 To 18)
For SRow = 1 To UBound(ish)
If Data_Otgr = ish(SRow, 18) Then
NRow = NRow + 1
'===>
kon(NRow, 1) = ish(SRow, 1)
kon(NRow, 2) = ish(SRow, 2)
kon(NRow, 3) = ish(SRow, 3)
kon(NRow, 4) = ish(SRow, 4)
kon(NRow, 5) = ish(SRow, 5)
kon(NRow, 6) = ish(SRow, 6)
kon(NRow, 7) = ish(SRow, 7)
kon(NRow, = ish(SRow,
kon(NRow, 9) = ish(SRow, 9)
kon(NRow, 10) = ish(SRow, 10)
kon(NRow, 11) = ish(SRow, 11)
kon(NRow, 12) = ish(SRow, 12)
kon(NRow, 13) = ish(SRow, 13)
kon(NRow, 14) = ish(SRow, 14)
kon(NRow, 15) = ish(SRow, 15)
kon(NRow, 16) = ish(SRow, 16)
kon(NRow, 17) = ish(SRow, 17)
kon(NRow, 18) = ish(SRow, 18)
'===>
End If
Next SRow
If NRow = 0 Then
MsgBox "í"
Else
Workbooks(namess).Sheets(qq).range("A4:R4").Rsize(NRow) = kon
End If
End Sub
fynt1l, код следует оформлять соответствующим тегом. Ищите такую кнопку (см. скрин) и исправьте своё сообщение. И предложите новое название темы, из которого будет понятна проблема/задача - модераторы поменяют. Не помешает небольшой файл-пример.
Тема: VBA. Перемещение строк между листами с использованием массивов Без файлов как-то так (не проверял)
Скрытый текст
Код
Sub df()
Dim I&, N&, Data_Otgr$
Dim delRows As Range
Dim ish(), kon()
Data_Otgr = nameOper
Application.ScreenUpdating = False
With Workbooks(moz).Sheets(qq)
ish = .Range("A4:R" & .Cells(.Rows.Count, "R").End(xlUp).Row).Value
End With
ReDim kon(1 To UBound(ish), 1 To 18)
For I = 1 To UBound(ish)
If ish(I, 18) = Data_Otgr Then
N = N + 1
For J = 1 To 18
kon(N, J) = ish(SRow, J)
Next
If Not delRows Is Nothing Then
Set delRows = Union(delRows, Workbooks(moz).Rows(SRow + 3))
Else
Set delRows = Workbooks(moz).Rows(SRow + 3)
End If
End If
Next
If N <> 0 Then
Workbooks(namess).Sheets(qq).Range("A4").Rsize(N, 18) = kon
delRows.Delete
End If
Application.ScreenUpdating = True
End Sub
Согласие есть продукт при полном непротивлении сторон
а давай те теперь проведем работу с массивами без массивов с какого диапазона в какой должны попасть данные можно узнать? без кодов, шифров, явок. ставок и прочей шпиогской лабуды, а просто своими словами опишите задачу ссылаясь на имена листов, адреса диапазонов
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
Проблема быстродействия макроса. Как решить с помощью массивов. Тема.
Создал файл в нем со страницы Reestrs надо перенести данные на страницу reestrs1. по параметру Sheets(reestrs).cells(i,18)= Sheets(reestrs1).cells(1,1). На листе reestrs1 эти строки должны добавиться в конец на листе reestrs удалиться. С помощью массивов. sanja тот код не работает.
Sanja, Все строки то что были до этого удаляются. Вставляются только новые данные. Можешь глянуть пример из приложенного файла. сообщение №5. В свой макрос я внедрю мне бы понять как чтобы из одного места удалялось а в другое в конец вставлялось.
fynt1l написал: На листе reestrs1 эти строки должны добавиться в конец на листе reestrs удалиться.
Лист reestrs скопируйте, на скопированном листе удалите ненужные строки, теперь можно с этого листа разом скопировать-вставить в нужное место в reestrs1. Затем удалите ненужные на листе reestrs.
Function Строка_Свободная( _
ws As Worksheet) _
As Long
Dim r As Range
Set r = ws.Cells.Find(what:="*", SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious)
If r Is Nothing Then
Строка_Свободная = 1
Else
Строка_Свободная = r.Row + 1
End If
End Function