VBA скопировать автоматически отфильтрованные данные в новую книгу

Question

Ниже мой код, где я сталкиваюсь с проблемой.Из разных рабочих книг мне нужно создать 3 новых листа в новой рабочей книге.В одном я должен отфильтровать данные на основе имени листа из другой книги.Я застрял с копией отфильтрованных данных в новую рабочую книгу.до этого все работает нормально.

    Sub Click()
    Dim xRow As Long
    Dim wbnew, wb1, wb2, wb3, wb4 As Workbook
    Dim sht, Data As Worksheet
    Dim sh1, sh2, Filter As String
    Dim Name As String
    Dim rng As Range

'открытые файлы для работы с

    Workbooks.Open filename:="C:\Users\File1.xlsx", ReadOnly:=True
    Workbooks.Open filename:="C:\Users\File2.xlsx", ReadOnly:=True
    Workbooks.Open filename:="C:\Users\File3.xlsx", ReadOnly:=True
    Workbooks.Open filename:="C:\Users\File4.xlsx", ReadOnly:=True

    wb1 = "File1.xlsx"
    wb2 = "File2.xlsx"
    Set wb3 = Workbooks("File3.xlsx")

' здесь я создаю временный файл

    Set wbnew = Workbooks.Add
    ActiveSheet.Name = "Data"

', определяющий столбцы Iбудет работать с

    sh1 = wb3.ActiveSheet.Range("A" & i).Value
    sh2 = wb3.ActiveSheet.Range("B" & i).Value
    Name = wb3.ActiveSheet.Range("F" & i).Value
    Filter = wb3.ActiveSheet.Range("C" & i).Value

'Основная цель - скопировать данные из 3 разных файлов в новую рабочую книгу.Ниже, начиная с копирования данных

    Workbooks(wb1).Worksheets(sh1).Copy _
    Before:=wbnew.Sheets(1)
    Workbooks(wb2).Worksheets(sh2).Copy _
    Before:=wbnew.Sheets(2)

'из третьего файла, я должен автоматически отфильтровать данные для столбца U в File4.xlsx с критериями из File3.xlsx, определенными выше

    Set wb4 = Workbooks("File4.xlsx")
    wb4.Activate
    xRow = wb4.Worksheets("Transactions").Range("A1").End(xlDown).Row
    wb4.Worksheets("Transactions").AutoFilterMode = False

    wb4.Worksheets("Transactions").Range("A:U").AutoFilter Field:=21, Criteria1:=Filter, Operator:=xlFilterValues

' попытатьсяСкопируйте результат из автофильтра в новую рабочую книгу, чтобы получить 3 новых листа, но с ошибкой. Я также попытался выполнить дистанционное копирование без успеха

    Workbooks(wb4).ActiveSheet.Range("A1:U" & xRow).SpecialCells(xlCellTypeVisible).Copy _
    Destination:=wbnew.Sheets("Data")

    wb4.Worksheets("Transactions").AutoFilterMode = False
    End Sub

Я ценю ваш совет.Спасибо

Answer 1

Вам необходимо указать диапазон для пункта назначения:

Workbooks(wb4).ActiveSheet.Range("A1:U" & xRow).SpecialCells(xlCellTypeVisible).Copy _
Destination:=wbnew.Sheets("Data").Range("A1:U" & xRow)

Answer 2

(написано на моем телефоне, возможны опечатки): используйте расширенный фильтр: -

Sub Click()
    Dim xRow As Long
    Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook, wb4 As Workbook, wbNew as workbook
    Dim sht as worksheet, Data As Worksheet
    Dim sh1 as string, sh2 as string, Filter As String
    Dim Name As String
    Dim rng As Range
'openin files to work with

   set wb1 =  Workbooks.Open(filename:="C:\Users\File1.xlsx", ReadOnly:=True)
    set wb2 = Workbooks.Open(filename:="C:\Users\File2.xlsx", ReadOnly:=True)
    set wb3 = Workbooks.Open(filename:="C:\Users\File3.xlsx", ReadOnly:=True)
   set wb4 = Workbooks.Open(filename:="C:\Users\File4.xlsx", ReadOnly:=True_
  set wbNew = workbooks.add()
   dim i as long 'this was missing
   i = 1 'what should this be?

'defining columns I will work with
with wb3.Sheets(1)
    sh1 = .Range("A" & i).Value
    sh2 = .Range("B" & i).Value
    Name = .Range("F" & i).Value
    Filter = .Range("C" & i).Value
end with
wb3.close false
'main goal is to copy data from 3 different files to new workbook. Below starting with copying data

    wb1.Worksheets(sh1).Copy Before:=wbnew.Sheets(1)
    wb1.close false
    wb2.Worksheets(sh2).Copy  before:=wbnew.Sheets(2)
    wb2.close false
'from third file I have to autofilter data for column U in File4.xlsx with criteria from File3.xlsx defined above


   with  wb4.Worksheets("Transactions")
            xRow =.Range("A1").End(xlDown).Row
          .range("Z1") = .range("U1")  'I assume Z is clear - insert heading
          .range("Z2") = filter        'insert value
           .range("a1:u1").copy wbnew.sheets("Data").range("a1")  'copy headings
          .range("a1:u" & xrow).AdvancedFilter _
          Action:=xlFilterCopy, _
          CriteriaRange:=.range(2z1:z2"), _
          CopyToRange:=wbnew.Sheets("Data").range("A1:u1")

    End With

    End Sub