Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Копирование строк из одного документа в другой, Копирование строк из одного документа в другой по выделенным ячейкам
 
#1
21.02.2019 20:06:46
Здравствуйте!
Подскажите, пожалуйста, как можно сделать так, чтобы строки копировались (где найдена определенная ячейка) со всех листов одного документа, в другой документ?
Заранее спасибо!
Код
Sub Poisk()

Dim i&, iCnt1&
Dim sh As Worksheet '

For Each sh In Worksheets
For i = 1 To 500

    If UCase(sh.Cells(i, 3).Value) Like UCase("Надякина Р.Ф.") Then iCnt1 = iCnt1 + 1
  
Next i
Next sh

MsgBox "На листе " & iCnt1 & " Надякина Р.Ф."

End Sub
 
 
 
#2
21.02.2019 21:22:18
Собираете строки посредством Union , потом копируете, далее создаете/открываете файл, указываете верхний левый угол для вставки и вставляете скопированное ранее.
После нахождения строки первый раз:
Код
Set RR=sh.Cells(i, 3).EntireRow

При втором и далее:
Код
Set RR=Union(RR,sh.Cells(i, 3).EntireRow)

По окончании цикла проверяете счётчик, если не ноль то:
Код
Set wb=WorkBooks.Open("путь к файлу\имя файла вместе с расширением")
RR.Copy wb.Sheets("название нужного листа").Range("левый верхний угол вставки")
 
 
 
#3
22.02.2019 02:09:01
Традиционный способ
Код
Option Explicit

Sub ksioP()
    Dim i&, j&, chto, est
    Dim wb As Workbook, ws As Worksheet
    
    i = 1
    chto = "Nadyakina R.F."
    
    Set wb = Workbooks.Add 'Tut peredacha v druguyu knigu, naprimer v novuyu
    
    With ThisWorkbook
        For Each ws In .Worksheets
            est = Application.Match(chto, ws.Range("a1").CurrentRegion.Columns(3), 0)
            If Not IsError(est) Then
                i = i + 1
                j = ws.Range("a1").CurrentRegion.Columns.Count
                'Tut peredacha v druguyu knigu, naprimer v novuyu
                wb.Sheets(1).Range("a" & i).Resize(1, j).Value = ws.Range("a" & est).Resize(1, j).Value
            End If
        Next
    End With
    
    j = wb.Sheets(1).Range("a2").CurrentRegion.Columns.Count
    
    For i = 1 To j
        wb.Sheets(1).Cells(1, i).Value = "Zagolovok " & CStr(i)
    Next
End Sub
 
 
 
#4
22.02.2019 07:12:28
Anchoret, а не могли бы вы подсказать, в какую часть моего кода это надо вставлять. А то я не могу понять
 
 
 
#5
22.02.2019 19:49:39
Servang,
Код
Sub Poisk()
Dim i&, j&, a&, sh As Worksheet, aa As Range, WB As Workbook, bb As Range, newWB As Workbook
i = 1: Set WB = ThisWorkbook
Set newWB = Workbooks.Add
For Each sh In WB.Worksheets
  a = 0: Set aa = Intersect(sh.UsedRange, sh.Columns(3)).Find("Надякина Р.Ф.", , xlValues, xlPart, xlByColumns, , True)
  If Not aa Is Nothing Then
    Set bb = aa.EntireRow: j = aa.Row: a = a + 1
    Do
      Set aa = Intersect(sh.UsedRange, sh.Columns(3)).FindNext(aa)
      If aa.Row = j Then Exit Do
      Set bb = Union(bb, aa.EntireRow): a = a + 1
    Loop Until aa.Row < j
    bb.Copy newWB.Sheets(1).Cells(i, 1): i = i + a
  End If
Next sh
End Sub
Изменено: Anchoret - 22.02.2019 20:09:54
 
 
 
Страницы: 1
Наверх