2

有没有办法可以将以下代码更改为仅复制特定的单元格范围或列：

例如：我在从 A 到 Z 的所有列中都有数据。我想将数据复制到另一张工作表，但我只想从 A、D、H 和 J 列（A2、D2、H2、J2）复制数据。

Option Explicit

Private Sub Worksheet_Activate()
Dim LR As Long

Me.UsedRange.Offset(1).ClearContents                'clear existing data

With Sheets("Raw - Incident Request Report")
    .AutoFilterMode = False                         'remove any prior filtering
    .Rows(1).AutoFilter                             'activate autofilter
    .Rows(1).AutoFilter 27, Criteria1:="Breached"   'filter column D for 80%+
    LR = .Range("D" & .Rows.Count).End(xlUp).Row    'is any data visible?
    If LR > 1 Then
        .Range("AC7:AC" & LR).Copy Range("C3")      'copy any data visible to report
        .Range("D7:D" & LR).Copy Range("D3")
        .Range("I7:I" & LR).Copy Range("E3")
        .Range("K7:K" & LR).Copy Range("F3")
        .Range("T7:T" & LR).Copy Range("G3")
    Else
        Range("C3") = "No Data Found"               'if none, give that message
    End If
    .AutoFilterMode = False                         'turn off autofilter
End With

End Sub

最终代码 - 编辑：

Option Explicit

Private Sub Worksheet_Activate()
Dim LR As Long

Me.UsedRange.Offset(17).ClearContents

With Sheets("Raw - Incident Request Report")
    .AutoFilterMode = False
    LR = .Range("D" & .Rows.Count).End(xlUp).Row
    .Range("D6:AH" & LR).AutoFilter Field:=26, Criteria1:="<>"

    If LR > 1 Then
        .Range("AC7:AC" & LR).Copy
        Sheets("Tickets").Range("C17").PasteSpecial xlPasteValues
        .Range("D7:D" & LR).Copy
        Sheets("Tickets").Range("D17").PasteSpecial xlPasteValues
        .Range("I7:I" & LR).Copy
        Sheets("Tickets").Range("E17").PasteSpecial xlPasteValues
        .Range("K7:K" & LR).Copy
        Sheets("Tickets").Range("F17").PasteSpecial xlPasteValues
        .Range("T7:T" & LR).Copy
        Sheets("Tickets").Range("G17").PasteSpecial xlPasteValues
    Else
        Range("C17") = "No Data Found"
    End If
    .AutoFilterMode = False
End With

End Sub
4

3 回答 3

1

未经测试，但尝试更改

.Range("A2:F" & LR).Copy Range("A2")

至

.Range("H2:H" & LR).Copy Range("A2")        'copy any data visible to report
.Range("D2:D" & LR).Copy Range("B2")
.Range("J2:J" & LR).Copy Range("C2")
.Range("A2:A" & LR).Copy Range("D2")

编辑：

当您的过滤器标题位于第 6 行时，您尝试在第 1 行进行过滤。您还应该尝试设置确切的范围以应用自动过滤器而不是整个行。

.AutoFilterMode = False
.Range("D6:AF6").AutoFilter Field:=24, Criteria1:="Breached"

此外，您的 PasteSpecial 不起作用，因为语法不正确。您必须先复制，然后在某个范围内进行 PasteSpecial。

http://msdn.microsoft.com/en-us/library/office/ff839476.aspx

于 2013-05-07T14:13:06.493 回答
0

这是您的代码的修改版本，用于将数组用于范围并减少重复。请注意，这篇文章的正确答案是 Joseph4tw，我的答案只是代码建议。

Private Sub Worksheet_Activate()
Dim LR As Long, MyCopyRange As Variant, MyPasteRange As Variant, X As Long

Me.UsedRange.Offset(17).ClearContents

With Sheets("Raw - Incident Request Report")
    .AutoFilterMode = False
    LR = .Range("D" & .Rows.Count).End(xlUp).Row
    MyCopyRange = Array("AC7:AC" & LR, "D7:DC" & LR, "I7:IC" & LR, "K7:K" & LR, "T7:TC" & LR) 'Put ranges in an array
    MyPasteRange = Array("C17", "D17", "E17", "F17", "G17")
    .Range("D6:AH" & LR).AutoFilter Field:=26, Criteria1:="<>"

    If LR > 1 Then
        For X = LBound(MyCopyRange) To UBound(MyCopyRange) 'Loop the array copying and pasting based on element in the array
            .Range(MyCopyRange).Copy
            Sheets("Tickets").Range(MyPasteRange).PasteSpecial xlPasteValues
        Next
    Else
        Range("C17") = "No Data Found"
    End If
    .AutoFilterMode = False
End With

End Sub
于 2015-06-26T01:34:22.547 回答
0 
Private Sub Worksheet_Activate()
Dim LR As Long, MyCopyRange As Variant, MyPasteRange As Variant, X As Long
Dim J as Integer

Me.UsedRange.Offset(17).ClearContents

With Sheets("Raw - Incident Request Report")
.AutoFilterMode = False
LR = .Range("D" & .Rows.Count).End(xlUp).Row
MyCopyRange = Array("AC7:AC" & LR, "D7:DC" & LR, "I7:IC" & LR, "K7:K" & 
LR, "T7:TC" & LR) 'Put ranges in an array
MyPasteRange = Array("C17", "D17", "E17", "F17", "G17")
.Range("D6:AH" & LR).AutoFilter Field:=26, Criteria1:="<>"

      If LR > 1 Then
  
        For X = LBound(MyCopyRange) To UBound(MyCopyRange) 'Loop the array copying and pasting based on element in the array
       .Range(MyCopyRange(j)).COPY 'added the missing arrary j
            Sheets("Sheet1").Range(MyPasteRange(j)).PasteSpecial xlPasteValues
            j = j + 1 'added
        Next
    Else
        Range("A2") = "No Data Found for this month"
    End If

End With

End Sub

' 此代码已经过测试。仍然归功于上述人

于 2021-01-14T15:48:57.803 回答