如何使用 VBA 复制特定列

Question

Is there a way I can change the following code to only copy specific cells range or columsn:

For example: I have data in all columns from A to Z. I want to copy data to another sheet but I only want to copy the data from Column A, D, H and 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

---

FINAL CODE - EDITED:

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

Answer 1

Untested, but try changing

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

to

.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")

EDIT:

You are trying to filter on Row 1 when your filter headers are on row 6. You should also try to set the exact range to apply an autofilter on as well rather than the entire row.

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

Also, your PasteSpecial isn't working because the syntax isn't correct. You have to Copy first, then PasteSpecial on a range.

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

Answer 2

Here is a modified version of your code to use arrays for the ranges and cut down on repetition. Please note, the correct answer to this post is Joseph4tw, my answer is just code advice.

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

Answer 3

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

' this code has been tested. credit still given to the above guy