выбрать диапазон после фильтра - Microsoft Office Excel

sergser · 20.01.2015, 16:03

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

Код:


Private Sub CommandButton21_Click()

Dim k, i As Integer, DayWeek As Integer
Dim wsSh, sh As Worksheet

With Application
  lCalc = .Calculation
  .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual
  End With
  On Error Resume Next
  
 DayWeek = DatePart("w", Date)  'создаем нов лист c проверкой на дубль
If DayWeek = 6 Then 'если день недели-пятница
strDate = Format(Now + 3, "dd.mm.yy")
Else
strDate = Format(Now + 1, "dd.mm.yy")
End If
    On Error Resume Next
    Set wsSh = Sheets(strDate)
    If wsSh Is Nothing Then Sheets.Add(, Sheets(Sheets.Count)).Name = strDate
    
     
  
Windows("gor.xls").Activate 'идем в другую книгу

Set wsSh = Sheets(strDate)
If wsSh Is Nothing Then Sheets.Add(, Sheets(Sheets.Count)).Name = strDate 'создаем нов лист c проверкой на дубль
Set sh = Sheets("avtclav")
Worksheets(sh).Activate
 Worksheets(sh).ShowAllData 'снимем все фильтры что враги наставили
 
Range("A5:bg5").AutoFilter 'фильтр в пятой строке шапка большая
        
        With Workbooks("gor.xls").sh
        
        sh.UsedRange.AutoFilter 44, "АВТОКЛАВ"
        sh.UsedRange.AutoFilter 39, "<>"
        sh.UsedRange.Offset(5).Resize(2, 2).SpecialCells(12).Copy _
        wsSh.[A2] 'вот тут он не копирует нужно скопировать 2, 7, 17, 19 столбцы
        'а в конце в столбике 55 проставить сегодняшнюю дату в каждой строчке
        'и пеhеносит полученную таблицу в файл откуда запускается макрос, ну тут я думаю справлюсь
         
    End With

sergser · 21.01.2015, 09:52

методом проб понял что вытаскивать столбцы смысла нет, лучше скопировать всю таблицу, а потом через массив вытащить нужные столбцы
Вот только почемуто копирует с переменным успехом то копирует то нет, заплутался что-то я
Может кто наставит на путь истинный

код поправил немного

Код:

Dim k, i As Integer, DayWeek As Integer
Dim wsSh, sh As Worksheet

With Application
  
  .ScreenUpdating = False:
  End With
  On Error Resume Next
  
 DayWeek = DatePart("w", Date)  'создаем нов лист c проверкой на дубль
If DayWeek = 6 Then 'если день недели-пятница
strDate = Format(Now + 3, "dd.mm.yy")
Else
strDate = Format(Now + 1, "dd.mm.yy")
End If
    On Error Resume Next
    Set wsSh = Sheets(strDate)
    If wsSh Is Nothing Then Sheets.Add(, Sheets(Sheets.Count)).Name = strDate
    
     
  
Windows("gor.xls").Activate 'идем в другую книгу
Set wsSh = Sheets(strDate)
If wsSh Is Nothing Then Sheets.Add(, Sheets(Sheets.Count)).Name = strDate 'создаем нов лист c проверкой на дубль

Set sh = Sheets("avtclav")

Worksheets("avtclav").Activate
Windows("gor.xls").Activate
 sh.ShowAllData 'снимем все фильтры что враги наставили
 
    Range("A5:bg5").AutoFilter 'фильтр в пятой строке шапка большая
        
        With Workbooks("gor.xls").sh
        
        sh.UsedRange.AutoFilter 44, "АВТОКЛАВ"
        sh.UsedRange.AutoFilter 39, "<>"
        sh.UsedRange.Offset(1).Resize(, 22).SpecialCells(12).Copy wsSh.[A2]
        wsSh.Activate
        i = .Cells(Rows.Count, 2).End(xlUp).Row + 1
       sh.Activate
       sh.ShowAllData
       
       sh.UsedRange.AutoFilter 44, "АВТОКЛАВ"
        sh.UsedRange.AutoFilter 40, "<>"
                
        sh.UsedRange.Offset(5).Resize(, 22).SpecialCells(12).Copy wsSh.[A&i]
        
        MsgBox i
     Windows("gor.xls").Activate
       wsSh.Activate
       
        
        'а в конце в столбике 55 проставить сегодняшнюю дату в каждой строчке
        'и пеhеносит полученную таблицу в файл откуда запускается макрос, ну тут я думаю справлюсь
         
    End With

IgorGO · 21.01.2015, 15:52

Вы запутались, мы понять не можем что нужно

какой-то замкнутый круг...

sergser · 21.01.2015, 16:14

Допилил проблемный участок, для проставновки даты, вообще переслал копировать

Код:

 With sh    ' вот этого места начитнаются грабли
                
            sh.UsedRange.AutoFilter 44, "АВТОКЛАВ"
            sh.UsedRange.AutoFilter 39, "<>"
            For i = .Cells(.Rows.Count, 2).End(xlUp).Row To 1 Step -1
            .Cells(i, 55) = Now
            Next
                
            sh.UsedRange.Offset(1).Resize(, 22).SpecialCells(12).Copy wsSh.[A2]
            wsSh.Activate
                
        sh.Activate
        sh.ShowAllData
            
        sh.UsedRange.AutoFilter 44, "АВТОКЛАВ"
            sh.UsedRange.AutoFilter 40, "<>"
            For i = .Cells(.Rows.Count, 2).End(xlUp).Row To 1 Step -1
            .Cells(i, 55) = Now
            Next
                
            i = .Cells(.Rows.Count, 2).End(xlUp).Row
            sh.UsedRange.Offset(5).Resize(, 22).SpecialCells(12).Copy wsSh.[A&i]
                
            MsgBox i
        Windows("gor.xls").Activate
        wsSh.Activate

Может синтаксис не правильный, не работает код,

sergser · 22.01.2015, 10:01

парни я чет вообще перестал понимать, беру 2 файла один с кодом и второй с которым он работает, переношу на домашний комп, запускаю все нормуль все работает, а на работе ни в какую, я вот думаю может админы чё нить пофиксили, мож библиотеку какую.
скажите для SpecialCells(12). должна быть специальная библиотека?

RAN. · 22.01.2015, 12:39

Код:

Sub q()
    Set r = Me.AutoFilter.Range
    r.Select
    r.AutoFilter 1, 1
    r.AutoFilter 3, "<>"
    r.Copy [A1]
    Me.ShowAllData
End Sub

sergser · 22.01.2015, 14:58

Спасибо за ответ, порылся в инторнетах не нашел примера, если вас не затруднит прикрутить этот фрагмент к моему коду хотябы к одому фильтру буду вам оч признателен, или может напишите некоторые пояснения....чет никак не получается запустить..

Заранее спасибо огромное, а то уж я думал что спрашиваю что то из ряда вон выходящее...

RAN. · 22.01.2015, 18:58

Код:

Sub qq()
    Dim k, i As Integer, DayWeek As Integer, strDate$
    Dim wsSh As Worksheet, sh As Worksheet
    Dim r As Range, rr As Range

    '    With Application
    '        lCalc = .Calculation
    '        .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual
    '    End With
    On Error Resume Next

    DayWeek = DatePart("w", Date)  'создаем нов лист c проверкой на дубль
    If DayWeek = 6 Then    'если день недели-пятница
        strDate = Format(Now + 3, "dd.mm.yy")
    Else
        strDate = Format(Now + 1, "dd.mm.yy")
    End If
    On Error Resume Next

    If wsSh Is Nothing Then
        Set wsSh = Sheets.Add(, Sheets(Sheets.Count))
        wsSh.Name = strDate
    Else
        Set wsSh = Sheets(strDate)
    End If

    '    Windows("gor.xls").Activate    'идем в другую книгу
    '    Set wsSh = Sheets(strDate)
    '    If wsSh Is Nothing Then Sheets.Add(, Sheets(Sheets.Count)).Name = strDate    'создаем нов лист c проверкой на дубль

    On Error GoTo 0
    Set sh = Sheets("avtclav")
    If sh.AutoFilterMode Then
        sh.Range("A1").AutoFilter    'снимем все фильтры что враги наставили
    End If

    With sh
        .Range("A5:bg5").AutoFilter    'фильтр в пятой строке шапка большая
        Set r = .AutoFilter.Range
        r.AutoFilter 44, "АВТОКЛАВ"
        r.AutoFilter 39, "<>"
        Set rr = Intersect(r, Union(.Columns(2), .Columns(7), .Columns(17), .Columns(19)))
        rr.Copy wsSh.[A2]
    End With
End Sub

sergser · 23.01.2015, 08:51

Спасибо огромное, уважаемый RAN, очень интересное решение и главное рабочее, сначала он матерился чуток, я его ткнул носом в лист где ему работать и он замолчал, выложу сюда рабочий код, может пригодится кому нить

Код:

Sub qq()
    Dim k, i As Integer, DayWeek As Integer, strDate$
    Dim wsSh As Worksheet, sh As Worksheet
    Dim r, w As Range, rr, ww As Range

    '    With Application
    '        lCalc = .Calculation
    '        .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual
    '    End With
    On Error Resume Next

    DayWeek = DatePart("w", Date)  'создаем нов лист c проверкой на дубль
    If DayWeek = 6 Then    'если день недели-пятница
        strDate = Format(Now + 3, "dd.mm.yy")
    Else
        strDate = Format(Now + 1, "dd.mm.yy")
    End If
    On Error Resume Next
Set wsSh = Sheets(strDate)
    If wsSh Is Nothing Then
        Set wsSh = Sheets.Add(, Sheets(Sheets.Count))
        wsSh.Name = strDate
    Else
        Set wsSh = Sheets(strDate)
    End If

     Windows("gor.xls").Activate    'идем в другую книгу
    '    Set wsSh = Sheets(strDate)
    '    If wsSh Is Nothing Then Sheets.Add(, Sheets(Sheets.Count)).Name = strDate    'создаем нов лист c проверкой на дубль

    On Error GoTo 0
    Set sh = Sheets("avtclav")
    If sh.AutoFilterMode Then
        sh.Range("A1").AutoFilter    'снимем все фильтры что враги наставили
    End If

    With sh
        .Range("A6:bg6").AutoFilter    'фильтр в пятой строке шапка большая
        Set r = .AutoFilter.Range
        r.AutoFilter 44, "АВТОКЛАВ"
        r.AutoFilter 39, "<>"
        Set rr = Intersect(r, Union(.Columns(6), .Columns(2), .Columns(7), .Columns(17), .Columns(19), .Columns(39)))
        rr.Copy wsSh.[b3]
        
        With wsSh

sergser · 23.01.2015, 10:55

Добрый день, друзья опять грабли там где не ждали, девочки которые работают с файликом понаставиль группировок и макрос отбирает неверно скажите команду на сятие группировки, но не на удаление

Код:


With .
        .ClearOutline
 End With

вот это не подходит, он их удаляет и они сегодня меня чуть не побили

чуть не забыл

.Ungroup - тоже снес все группировки,
а мне нужно чтобы эти гребанные плюсики остались и просто раскрылись

21.01.2015, 15:52	#3
IgorGO Новичок СтарожилДжуниор Регистрация: 05.02.2008 Сообщений: 9,487	Вы запутались, мы понять не можем что нужно какой-то замкнутый круг... Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете

22.01.2015, 12:39	#6
RAN. Форумчанин Регистрация: 05.07.2011 Сообщений: 208	Код: `Sub q() Set r = Me.AutoFilter.Range r.Select r.AutoFilter 1, 1 r.AutoFilter 3, "<>" r.Copy [A1] Me.ShowAllData End Sub`

23.01.2015, 10:55	#10
sergser Пользователь Регистрация: 16.06.2013 Сообщений: 11	Добрый день, друзья опять грабли там где не ждали, девочки которые работают с файликом понаставиль группировок и макрос отбирает неверно скажите команду на сятие группировки, но не на удаление Код: `With . .ClearOutline End With` вот это не подходит, он их удаляет и они сегодня меня чуть не побили чуть не забыл .Ungroup - тоже снес все группировки, а мне нужно чтобы эти гребанные плюсики остались и просто раскрылись Последний раз редактировалось sergser; 23.01.2015 в 11:01.

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Выбрать часть строки после последнего указанного символа	EndoCrinolog	PHP	2	15.11.2012 14:00
Значение после 15 запятой, выбрать	bonapartw	Помощь студентам	4	03.01.2012 21:19
Перенос (копирование) данных после фильтра	Klubnik	Microsoft Office Excel	0	08.12.2011 17:22
MySQL выбрать все сообщения после моего	ADSoft	SQL, базы данных	3	11.03.2011 13:28
Как выбрать диапазон во время работы UserForm?	Simbad	Microsoft Office Excel	3	10.12.2009 14:28

22.01.2015, 10:01	#5
sergser Пользователь Регистрация: 16.06.2013 Сообщений: 11	парни я чет вообще перестал понимать, беру 2 файла один с кодом и второй с которым он работает, переношу на домашний комп, запускаю все нормуль все работает, а на работе ни в какую, я вот думаю может админы чё нить пофиксили, мож библиотеку какую. скажите для SpecialCells(12). должна быть специальная библиотека?

22.01.2015, 14:58	#7
sergser Пользователь Регистрация: 16.06.2013 Сообщений: 11	Спасибо за ответ, порылся в инторнетах не нашел примера, если вас не затруднит прикрутить этот фрагмент к моему коду хотябы к одому фильтру буду вам оч признателен, или может напишите некоторые пояснения....чет никак не получается запустить.. Заранее спасибо огромное, а то уж я думал что спрашиваю что то из ряда вон выходящее...