如何使用VBA复制特定列
如何使用VBA复制特定列
提问于 2013-05-07 13:56:50
是否可以将以下代码更改为只复制特定的单元格范围或列：
例如:我有从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回答 3
Stack Overflow用户
发布于 2013-05-07 14:13:06
未经测试，但请尝试更改
.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
Stack Overflow用户
发布于 2015-06-26 01:34:22
下面是您的代码的一个修改版本，用于对范围使用数组，并减少重复。请注意，这篇文章的正确答案是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 SubStack Overflow用户
发布于 2021-01-14 15:48:57
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这段代码已经过测试。信用仍然给予了上述的人
页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接：
https://stackoverflow.com/questions/16420923
复制相关文章
相似问题
腾讯云开发者
