Question

我有一个循环，该循环根据单独的条件列表过滤表，然后将过滤后的表复制到新工作簿，保存工作簿，并将其附加到电子邮件中。

循环遍历条件列表，直到完成为止，这样会创建一些电子邮件。

我的问题是数据正确复制到第一个新工作簿，但在后续的工作簿/条件中却没有。

令人沮丧的是，在线上，

.Range("A1").PasteSpecial xlPasteAll

它确实复制了数据（逐步浏览时可以看到），但是紧随其后的是

.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths

将数据覆盖为空白单元格。

但是，这段代码在循环中第一次起作用，所以我不确定循环到底在哪里。关于这个问题或改进我的代码的任何建议（我意识到这很混乱）都将不胜感激！

Dim lastRow As Long
Dim sht2 As Worksheet
Dim lastRow2 As Long
Dim sht As Worksheet
Dim agency As String
Dim lastRow3 As Long
Dim newWB As Workbook
Dim myItem As Outlook.MailItem
Dim emailBody As String
Dim myolapp As Outlook.Application
Dim filename As String
Dim i As Long
Dim wb As Workbook
Dim newWS As Worksheet

Application.ScreenUpdating = False
Set myolapp = Outlook.Application
Set wb = ActiveWorkbook

Set sht = wb.ActiveSheet
lastRow = Range("A1").CurrentRegion.Rows.Count

Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Value = "Agency Code"
Range("A2").Formula = "=LEFT(B2, 3)"

Range("A2").Select
Selection.AutoFill Destination:=Range("A2:A" & lastRow)

Columns("A:A").Copy
Set sht2 = Sheets.Add

sht2.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

Application.CutCopyMode = False

ActiveSheet.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
lastRow2 = Range("A1").CurrentRegion.Rows.Count

For i = 2 To lastRow2

    Set newWB = Workbooks.Add
    Set newWS = newWB.Sheets("Sheet1")
    agency = sht2.Range("A" & i)

    sht.Range("$A$1:$J$" & lastRow).AutoFilter Field:=1, Criteria1:="=" & agency, _
    Operator:=xlAnd

    lastRow3 = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row

    sht.Range("B1:J" & lastRow3).Copy

    With newWS
        .Range("A1").PasteSpecial xlPasteAll
        .Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
    End With

    Application.CutCopyMode = False

    Rows("1:" & lastRow3).EntireRow.AutoFit

    newWB.SaveAs "C:\Users\dkmarsh\Desktop\" & agency & " Placement Stats"
    filename = newWB.FullName

    Set myItem = myolapp.CreateItemFromTemplate("C:\Users\me\AppData\Roaming\Microsoft\Templates\Placement (Agency) Templates\Placement Template.oft")
    emailBody = "Body"

    With myItem
        .Body = emailBody
        .Subject = agency & " Placement Files"
        .To = "you"
        .Attachments.Add filename
        .Display
    End With

    newWB.Close
    Kill filename

Next i

Application.ScreenUpdating = True

特殊粘贴通过循环覆盖数据第二次

0 个答案: