Блог

У меня есть несколько листов с макросами VBA, которые передают данные после автофильтрации.

Когда на листе нет данных после автофильтрации, макрос выдает ошибку времени выполнения 1004 в строке

 Workbooks("Predictology-Reports.xlsx").Sheets("FAL") _
          .Range("A" amp; Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
  

Вот полный макрос одного из них

 Sub FALAYS()
    Dim arr, ws As Worksheet, lc As Long, lr As Long

    arr = Array("L.FAL_19_New_Summer2", "L.FA_FAL_3", "L.FAL_19_New_Summer")

    Set ws = ActiveSheet
    'range from A1 to last column header and last row
    lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    lr = ws.Cells.Find("*", after:=ws.Range("A1"), LookAt:=xlPart, _
                        SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
   
    With ws.Range("A1", ws.Cells(lr, lc))
        .HorizontalAlignment = xlCenter
        .AutoFilter Field:=1, Criteria1:=arr, Operator:=xlFilterValues
        If .Rows.Count - 1 > 0 Then
            On Error Resume Next
            .Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
            On Error GoTo 0
        Else
            Exit Sub
        End If
    End With
      
    Workbooks("Predictology-Reports.xlsx").Sheets("FAL") _
          .Range("A" amp; Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    
    Application.CutCopyMode = False
End Sub
  

Попробуйте установить переменную диапазона для видимых строк, затем проверьте, установлена ли она перед копированием / вставкой.

 Sub FALAYS()
    Dim arr, ws As Worksheet, lc As Long, lr As Long, rngCopy As Range

    arr = Array("L.FAL_19_New_Summer2", "L.FA_FAL_3", "L.FAL_19_New_Summer")

    Set ws = ActiveSheet
    
    'range from A1 to last column header and last row
    lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    lr = ws.Cells.Find("*", after:=ws.Range("A1"), LookAt:=xlPart, _
                        SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
   
    With ws.Range("A1", ws.Cells(lr, lc))
        .HorizontalAlignment = xlCenter
        .AutoFilter Field:=1, Criteria1:=arr, Operator:=xlFilterValues
        If .Rows.Count  > 1 Then
        
            On Error Resume Next
            Set rngCopy = .Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
            
            If Not rngCopy Is Nothing Then
                rngCopy.Copy
                Workbooks("Predictology-Reports.xlsx").Sheets("FAL") _
                    .Range("A" amp; Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                Application.CutCopyMode = False
            End If   'have anything to copy
        
        End If
    End With
      
End Sub
  

Если это обычная задача, выделите ее в отдельный подраздел:

 'given a [filtered] table rngTable, copy visible data rows as values to rngDestination
Sub CopyVisibleRows(rngTable As Range, rngDestination As Range)
    Dim rngVis As Range
    If rngTable.Rows.Count > 1 Then
        On Error Resume Next
        Set rngVis = rngTable.Offset(1, 0).Resize(rngTable.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        If Not rngVis Is Nothing Then
            rngVis.Copy
            rngDestination.PasteSpecial xlPasteValues
        End If
    End If 'any source rows
End Sub
  

что сводит ваш исходный код к чему-то вроде:

 Sub FALAYS()
    Dim arr, ws As Worksheet, lc As Long, lr As Long, tbl As Range

    arr = Array("L.FAL_19_New_Summer2", "L.FA_FAL_3", "L.FAL_19_New_Summer")

    Set ws = ActiveSheet
    
    'range from A1 to last column header and last row
    lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    lr = ws.Cells.Find("*", after:=ws.Range("A1"), LookAt:=xlPart, _
                        SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set tbl = ws.Range("A1", ws.Cells(lr, lc))
    With tbl
        .HorizontalAlignment = xlCenter
        .AutoFilter Field:=1, Criteria1:=arr, Operator:=xlFilterValues
        If .Rows.Count  > 1 Then
        
            CopyVisibleRows  tbl, Workbooks("Predictology-Reports.xlsx").Sheets("FAL") _
                                    .Range("A" amp; Rows.Count).End(xlUp).Offset(1)          
        
        End If
    End With
      
End Sub 
  

В этот код можно внести множество улучшений, но он должен дать вам отправную точку.

Я присваиваю отфильтрованные ячейки диапазону, если есть ячейки, диапазон — это «что-то».

Затем скопируйте диапазон непосредственно на лист (вы можете пропустить метод копирования, вставки, перенеся значения в ячейки).

Совет: старайтесь избегать On Error Resume Next , если вы не знаете, что делаете, и это строго необходимо.

Прочитайте комментарии и настройте код в соответствии с вашими потребностями.

РЕДАКТИРОВАТЬ: добавлено OERN согласно предложению Тима

Код

 Public Sub FALAYS()
    
    Dim arrValues As Variant
    arrValues = Array("L.FAL_19_New_Summer2", "L.FA_FAL_3", "L.FAL_19_New_Summer")
    
    ' Set the target workbook and sheet
    Dim targetWorkbook As Workbook
    Dim targetSheet As Worksheet
    Set targetWorkbook = Workbooks("Predictology-Reports.xlsx")
    Set targetSheet = targetWorkbook.Worksheets("FAL")
    
    ' Set the source sheet and range
    Dim sourceSheet As Worksheet
    Dim sourceRange As Range
    Dim sourceColumn As Long
    Dim sourceRow As Long
    Set sourceSheet = ActiveSheet
    'range from A1 to last column header and last row
    sourceColumn = sourceSheet.Cells(1, sourceSheet.Columns.Count).End(xlToLeft).Column
    sourceRow = sourceSheet.Cells.Find("*", after:=sourceSheet.Range("A1"), LookAt:=xlPart, _
                        SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    With sourceSheet.Range("A1", sourceSheet.Cells(sourceRow, sourceColumn))
        .HorizontalAlignment = xlCenter
        .AutoFilter Field:=1, Criteria1:=arrValues, Operator:=xlFilterValues
        If .Rows.Count - 1 > 0 Then
            
            ' Set the cells to the source range
            On Error Resume Next
            Set sourceRange = .Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
            On Error Goto 0
            
            ' Validate if the source range has cells
            If Not sourceRange Is Nothing Then
                sourceRange.Copy targetSheet.Range("A" amp; Rows.Count).End(xlUp).Offset(1)
            Else
                Exit Sub
            End If
        End If
        
    End With

End Sub
  

Дайте мне знать, если это сработает.