Question

我有一些代码可以过滤数据并复制到新工作表中。

我在处理所有必需的列时遇到了一些困难，并且想知道是否有人可以帮助我。新表中有2个来源和2个目的地。有人可以指点我正确的方向吗？我在这里只包含了一半的宏因为我没有完成另一部分因为被困在这上面。

我也在努力使用我在代码顶部设置的“Insurer”来填充文件中的“Insurer”名称另存为，在这里作为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

将选定的过滤数据复制到新工作表

1 个答案: