Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Скопировать строки листов книги по условию
 
#1
03.10.2017 17:28:23
Добрий день!

Прошу помочь доработать макрос которий должен скопировать строки(в новий файл все строки с книги)
с заданого дапазона листов если ячейка С пустая
например, с листов 04.01.17 по 06.01.17(листов может бить больше)
Код
Sub atest_a1()
Application.ScreenUpdating = 0
Dim LastRow As Long
Dim wsSh As Worksheet
Set wsSh = Worksheets("04.01.17")
    For Each wsSh In ActiveWorkbook.Worksheets
        wsSh.Activate
    LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    Selection.AutoFilter
    wsSh.Range("$A$1:$O" & LastRow).AutoFilter Field:=3, Criteria1:="="
    Range("A2").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.Copy
    Workbooks.Add
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveSheet.Paste
 Next wsSh
 Application.ScreenUpdating = 1
End Sub
 
 
 
#2
03.10.2017 17:57:34
хотел скопировать на новий лист и тоже не получилось
Код
Sub a_test_a111()
Application.ScreenUpdating = 0
Dim LastRow As Long
Dim wsSh As Worksheet
Dim shRes As Worksheet
Dim lr As Long, i As Long, j As Long, r As Long
    Dim arrSrc(), arrRes()
Set wsSh = Worksheets("04.01.17")
 Set shRes = Worksheets("Лист6")
    For Each wsSh In ActiveWorkbook.Worksheets
        wsSh.Activate
    LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    arrSrc() = wsSh.Range("A2:J" & LastRow).Value
    ReDim arrRes(1 To UBound(arrSrc, 1), 1 To 10)
    For i = 2 To UBound(arrSrc, 1)
          If arrSrc(i, 3) = "" Then
            r = r + 1
            For j = 1 To 10
                arrRes(r, j) = arrSrc(i, j)
            Next
        End If
    Next
    If r = 0 Then
        GoTo endm
    End If
    Sheets("Лист6").Activate
    iRow = shRes.Cells(Rows.Count, 1).End(xlUp).Row + 1
    shRes.Cells(iRow, 1).Resize(r, 10).Value = arrRes()
    shRes.Activate
 Next wsSh
 Application.ScreenUpdating = 1
endm:
    Erase arrSrc, arrRes
End Sub
 
 
 
#3
03.10.2017 19:20:15
В первом примере заберите Selection.AutoFilter
У Вас каждый лист должен идти в новую книгу?
 
 
 
#4
03.10.2017 22:40:33
Все выбраные листы должны скопироватся в одну книгу
 
 
 
#5
04.10.2017 09:12:29
если в первом примере убрать  Selection.AutoFilte, то каждий лист идет в новою книгу, а нужно в одну.
как организовать в одну или на один лист и как организовать обработку только диапазона, например с листов 04.01.17 по 06.01.17
Сейчас обрабатываются все листи
Изменено: sergey2303 - 04.10.2017 10:57:03
 
 
 
#6
04.10.2017 09:47:30
Попробуйте такой вариант!
Код
Sub test()
Dim book As Workbook, ibook As Workbook
Dim sht As Worksheet, lrow&, lcolumn&, lastrow&, sht1 As Worksheet
Set book = ThisWorkbook
Set ibook = Workbooks.Add
Set sht1 = ibook.Sheets(1)
With book
    For Each sht In .Worksheets
        With sht
            lrow = .Cells(.Rows.Count, "a").End(xlUp).Row
            lcolumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
            .UsedRange.AutoFilter field:=3, Criteria1:="="
            lastrow = sht1.Cells(sht1.Rows.Count, "a").End(xlUp).Row
            .Range(.[a2], .Cells(2, lcolumn).End(xlDown)).Copy sht1.Cells(lastrow, "a")
        End With
    Next sht
End With
End Sub
"Все гениальное просто, а все простое гениально!!!"
 
 
 
#7
04.10.2017 09:53:34
Если нужны только значения то:
Код
.Range(.[a2], .Cells(2, lcolumn).End(xlDown)).Copy sht1.Cells(lastrow, "a")

замените на:
Код
 .Range(.[a2], .Cells(2, lcolumn).End(xlDown)).Copy
 sht1.Cells(lastrow, "a").PasteSpecial xlPasteValues
"Все гениальное просто, а все простое гениально!!!"
 
 
 
#8
04.10.2017 09:58:37
ошибка на строке
.UsedRange.AutoFilter Field:=3, Criteria1:="="  
Изменено: sergey2303 - 04.10.2017 10:34:40
 
 
 
#9
04.10.2017 10:50:45
А если предварительно убрать фильтр со всех листов. На каком листе стопорится? Все ли листы заполнены?
Изменено: Nordheim - 04.10.2017 10:51:34
"Все гениальное просто, а все простое гениально!!!"
 
 
 
#10
04.10.2017 10:54:30
фильтра на листах нет  
Изменено: sergey2303 - 04.10.2017 11:08:21
 
 
 
#11
04.10.2017 11:18:01
переделал немного свой вариант 2, но строки дублируются(код похоже отрабативает два раза), и как организовать
работу кода в диапазоне листов?
Код
Sub a_test_a111()
Application.ScreenUpdating = 0
Dim lastrow As Long
Dim wsSh As Worksheet
Dim shRes As Worksheet
Dim lr As Long, i As Long, j As Long, r As Long
    Dim arrSrc(), arrRes()
Set wsSh = Worksheets("04.01.17")
 Set shRes = Worksheets("Лист6")
    For Each wsSh In ActiveWorkbook.Worksheets
        wsSh.Activate
        lastrow = 0
    lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
        r = 0
    arrSrc() = wsSh.Range("A2:F" & lastrow).Value
    ReDim arrRes(1 To UBound(arrSrc, 1), 1 To 6)
    For i = 2 To UBound(arrSrc, 1)
          If arrSrc(i, 3) = "" Then
            r = r + 1
            For j = 1 To 6
                arrRes(r, j) = arrSrc(i, j)
            Next
        End If
    Next
         If r = 0 Then
        GoTo endm
    End If
    
    Sheets("Лист6").Activate
    iRow = shRes.Cells(Rows.Count, 1).End(xlUp).Row + 1
    shRes.Cells(iRow, 1).Resize(r, 6).Value = arrRes()
    shRes.Activate
Next wsSh
 Application.ScreenUpdating = 1
endm:
    Erase arrSrc, arrRes
End Sub
Изменено: sergey2303 - 04.10.2017 11:23:29
 
 
 
#12
04.10.2017 11:36:34
sergey2303,
А откуда в примере появился Лист6 ?
 
 
 
#13
04.10.2017 12:09:16
Добавил в пример из первого поста лист, его имя Лист1
Подкорректировал ваш код. Запускать при активном листе Лист1. Собирает данные с с листов 04.01.17 по 06.01.17
Код
Sub a_test_a111()
Application.ScreenUpdating = 0
Dim lastrow As Long
Dim wsSh As Worksheet
Dim shRes As Worksheet
Dim lr As Long, i As Long, j As Long, r As Long
Dim arrSrc(), arrRes()
'Set wsSh = Worksheets("04.01.17")
 Set shRes = Worksheets("Лист1")
  For Each wsSh In ActiveWorkbook.Worksheets
     If wsSh.Name <> "Лист1" And wsSh.Name <> "07.01.17" Then
        wsSh.Activate
        lastrow = 0
        lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
          r = 0
          arrSrc() = wsSh.Range("A2:F" & lastrow).Value
          ReDim arrRes(1 To UBound(arrSrc, 1), 1 To 6)
      For i = 2 To UBound(arrSrc, 1)
          If arrSrc(i, 3) = "" Then
            r = r + 1
            For j = 1 To 6
                arrRes(r, j) = arrSrc(i, j)
            Next
          End If
      Next
         If r = 0 Then
        GoTo endm
    End If
     
    Sheets("Лист1").Activate
    iRow = shRes.Cells(Rows.Count, 1).End(xlUp).Row + 1
    shRes.Cells(iRow, 1).Resize(r, 6).Value = arrRes()
    'shRes.Activate
   End If
  Next wsSh
 Application.ScreenUpdating = 1
endm:
    Erase arrSrc, arrRes
End Sub
 
 
 
#14
04.10.2017 12:36:49
Цитата
sergey2303 написал:
ошибка на строке
.UsedRange.AutoFilter Field:=3, Criteria1:="="  
Попробовал на вашем файле все работает. Макрос запускаете с книги из первого поста? Сам макрос в той же книге?
"Все гениальное просто, а все простое гениально!!!"
 
 
 
#15
04.10.2017 12:42:55
Kuzmich
у меня собирает с 03.01.17, и еще как собирать например,  с 05.01.17
 
 
 
#16
04.10.2017 12:45:48
Пробовали прогнать макрос ч.з. F8, дабы определить где происходит сбой?
"Все гениальное просто, а все простое гениально!!!"
 
 
 
#17
04.10.2017 12:59:38
Nordheim
ошибка на строке
.UsedRange.AutoFilter Field:=3, Criteria1:="="  
 
 
 
#18
04.10.2017 13:01:45
sergey2303, написал
Цитата
у меня собирает с 03.01.17, и еще как собирать например,  с 05.01.17
В макросе есть кусочек кода, отвечающий за перечень листов, с которых надо собирать данные
Код
 For Each wsSh In ActiveWorkbook.Worksheets
     If wsSh.Name <> "Лист1" And wsSh.Name <> "07.01.17" Then
 
 
 
#19
04.10.2017 13:22:30
Kuzmich
в робочем файле прописивваю
wsSh.name > "30.12.16", т.е хочу обработать все листи начиная с  03.01.17 и до конца , но почему то отрабатывается только лист  31.01.17
Код
If wsSh.name <> "Лист1" And wsSh.name > "30.12.16" Then
 
 
 
#20
04.10.2017 13:32:15
Kuzmich
т.е нужно обработать листи, имя которих не заканчивается на  ".16" или ".2016"
так не получается
Код
If wsSh.name <> "Лист1" And Not wsSh.name Like "*.16" Then
Изменено: sergey2303 - 04.10.2017 13:33:59
 
 
 
#21
04.10.2017 13:33:51
sergey2303,
Если у вас есть лист1, на который надо собирать данные со всех других листов в книге, то пишите
Код
For Each wsSh In ActiveWorkbook.Worksheets
     If wsSh.Name <> "Лист1"  Then
Если из сбора надо исключить какие-то листы, то пишите
Код
If wsSh.Name <> "Лист1" And wsSh.Name <> "07.01.17" Then
 
 
 
#22
04.10.2017 13:45:33
Kuzmich, Если не затруднит протестируйте мой код, у вас будет работать. Просто интересно, только у меня все работает или....
"Все гениальное просто, а все простое гениально!!!"
 
 
 
#23
04.10.2017 13:49:16
а почему так ничего не собирается
Код
If wsSh.name <> "Лист1" Or wsSh.name Like "*.17" Or wsSh.name Like "*.2017" Then
 
 
 
#24
04.10.2017 14:34:02
sergey2303,
Цитата
Если не затруднит протестируйте мой код, у вас будет работать
Код работает, не подтягивает только из листа 06.01.17 первую строку с пустой ячейкой в столбце С
 
 
 
#25
04.10.2017 15:02:37
Kuzmich, Если тестировали мой код, то первую строку он не тянет ни с какого листа, там копирование идет со второй строки.
"Все гениальное просто, а все простое гениально!!!"
 
 
 
#26
04.10.2017 15:51:23
Nordheim,
Я писал: первую строку с пустой ячейкой в столбце С
Надо изменить в коде (было For i = 2)
Код
      For i = 1 To UBound(arrSrc, 1)
          If arrSrc(i, 3) = "" Then
            r = r + 1
            For j = 1 To 6
                arrRes(r, j) = arrSrc(i, j)
            Next
Изменено: Kuzmich - 04.10.2017 15:59:36 (добавил, где ошибка)
 
 
 
#27
04.10.2017 16:22:00
так работает.
Всем большое спасибо
 
 
 
Страницы: 1
Наверх