如何使用VBA复制特定的列
有没有办法我可以改变下面的代码只复制特定的单元格范围或columsn：
例如：我有从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
未经testing，但尝试改变
.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")
编辑：
当您的filter标题位于第6行时，您正在尝试在第1行进行过滤。您还应该尝试设置确切范围，以便将自动filter应用于整个行而不是整个行。
.AutoFilterMode = False .Range("D6:AF6").AutoFilter Field:=24, Criteria1:="Breached"
此外，您的PasteSpecial不起作用，因为语法不正确。 你必须首先复制，然后粘贴特定的范围。
http://msdn.microsoft.com/en-us/library/office/ff839476.aspx
这里是你的代码的修改版本使用数组范围和减less重复。 请注意，这篇文章的正确答案是Joseph4tw，我的回答只是代码build议。
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