Копирование выбранных фильтрованных данных на новый лист

Question

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

У меня возникли трудности с копированием всех необходимых столбцов сразу, и мне было интересно, может ли кто-нибудь помочь мне в этом. На новом листе есть 2 источника и 2 адресата. Может ли кто-нибудь указать мне в правильном направлении? Я включил только одну половину макроса, так как я еще не закончил другую часть из-за того, что застрял на этом.

Я также пытаюсь использовать «страховщика», который я установил в верхней части кода, чтобы заполнить имя «страховщика» в файле save, так как здесь, как ABC, это возможно или мне нужно будет жесткий код это? Я искал, чтобы установить эту опцию в управлении петли через список компаний, которые мне нужно создать файл для

Dim LR As Integer 
Dim Insurer As Integer 
Dim InsurerNew As Integer 
Dim InsurerOld As Integer 




LR = Range("A" & Rows.Count).End(xlUp).Row 

Selection.AutoFilter 
ActiveSheet.Range("$A$1:$AD" & LR).AutoFilter Field:=22, Criteria1:=Insurer 

Workbooks.Open Filename:= _ 
    "G:\Accounts\FINANCE\Financial Data\Bordereau\Monthly Bordereau\CDL Insurer Template.xlsx" 

If Application.Subtotal(103, .Columns(3)) > 1 Then 
    .Columns(1).Offset(1, 0).Resize(.Rows.Count - 1, 1).Copy _ 
     Destination:=Workbooks("CDL Insurer Template.xls").Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) 
    .Columns(2).Offset(1, 0).Resize(.Rows.Count - 1, 1).Copy _ 
    Destination:=Workbooks("CDL Insurer Template.xls").Sheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0) 
    .Columns(3).Offset(1, 0).Resize(.Rows.Count - 1, 1).Copy _ 
     Destination:=Workbooks("CDL Insurer Template.xls").Sheets("Sheet1").Cells(Rows.Count, 3).End(xlUp).Offset(1, 0) 
    .Columns(4).Offset(1, 0).Resize(.Rows.Count - 1, 1).Copy _ 
    Destination:=Workbooks("CDL Insurer Template.xls").Sheets("Sheet1").Cells(Rows.Count, 4).End(xlUp).Offset(1, 0) 
     .Columns(5).Offset(1, 0).Resize(.Rows.Count - 1, 1).Copy _ 
    Destination:=Workbooks("CDL Insurer Template.xls").Sheets("Sheet1").Cells(Rows.Count, 5).End(xlUp).Offset(1, 0) 
    .Columns(6).Offset(1, 0).Resize(.Rows.Count - 1, 1).Copy _ 
    Destination:=Workbooks("CDL Insurer Template.xls").Sheets("Sheet1").Cells(Rows.Count, 6).End(xlUp).Offset(1, 0) 
    .Columns(7).Offset(1, 0).Resize(.Rows.Count - 1, 1).Copy _ 
    Destination:=Workbooks("CDL Insurer Template.xls").Sheets("Sheet1").Cells(Rows.Count, 7).End(xlUp).Offset(1, 0) 
    .Columns(8).Offset(1, 0).Resize(.Rows.Count - 1, 1).Copy _ 
    Destination:=Workbooks("CDL Insurer Template.xls").Sheets("Sheet1").Cells(Rows.Count, 8).End(xlUp).Offset(1, 0) 
    .Columns(9).Offset(1, 0).Resize(.Rows.Count - 1, 1).Copy _ 
    Destination:=Workbooks("CDL Insurer Template.xls").Sheets("Sheet1").Cells(Rows.Count, 9).End(xlUp).Offset(1, 0) 
    .Columns(10).Offset(1, 0).Resize(.Rows.Count - 1, 1).Copy _ 
    Destination:=Workbooks("CDL Insurer Template.xls").Sheets("Sheet1").Cells(Rows.Count, 10).End(xlUp).Offset(1, 0) 
    .Columns(11).Offset(1, 0).Resize(.Rows.Count - 1, 1).Copy _ 
    Destination:=Workbooks("CDL Insurer Template.xls").Sheets("Sheet1").Cells(Rows.Count, 11).End(xlUp).Offset(1, 0) 
    .Columns(12).Offset(1, 0).Resize(.Rows.Count - 1, 1).Copy _ 
    Destination:=Workbooks("CDL Insurer Template.xls").Sheets("Sheet1").Cells(Rows.Count, 12).End(xlUp).Offset(1, 0) 

ChDir "G:\Accounts\FINANCE\Financial Data\Bordereau\Monthly Bordereau\2015-03" 
ActiveWorkbook.SaveAs Filename:= _ 
    "G:\Accounts\FINANCE\Financial Data\Bordereau\Monthly Bordereau\2015-03\ABC 2015-03.xlsx" _ 
    , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 

Благодаря

Стивен

Answer 1

Этот код полностью UNTESTED , но он должен хотя бы дать вам идею ...

Option Explicit 

Sub CopyColumns() 
    Dim lastRow As Long 
    Dim insurer As Integer 
    Dim dataRange As Range 
    Dim subT As Range 
    Dim newWB As Workbook 
    Dim fName As String 
    Dim fPath As String 

    '--- determine the range of the data and filter it for the requested insurer 
    lastRow = Range("A" & Rows.Count).End(xlUp).Row 
    Set dataRange = Sheets("Sheet1").Range("$A$1:$AD" & lastRow) 
    insurer = 1 
    dataRange.AutoFilter Field:=22, Criteria1:="=" & insurer 

    '--- open the empty workbook template as the destination for the copied data 
    Set newWB = Workbooks.Open("G:\Accounts\FINANCE\Financial Data\Bordereau\Monthly Bordereau\CDL Insurer Template.xlsx") 

    '--- check the subtotal and copy the range only if the subtotal is more than 1 
    ' (put the SUBTOTAL formula in the cell to make it easier)\ 
    Set subT = dataRange.Cells(lastRow + 1, 3) 
    subT.Formula = "=SUBTOTAL(103," & dataRange.Offset(1, 2).Resize(lastRow - 1, 1).Address & ")" 
    If subT.Value > 1 Then 
     dataRange.Resize(lastRow, 12).Copy Destination:=newWB.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) 
    End If 

    '--- set up the workbook to save to the correct location 
    fPath = "G:\Accounts\FINANCE\Financial Data\Bordereau\Monthly Bordereau\2015-03\" 
    fName = "ABC 2015-03.xlsx" 
    newWB.SaveAs fPath & fName 
    newWB.Close 

End Sub