[英]VBA: Copy & Paste, Then Search, Copy & Paste
我需要你的帮助! :O当前,我有一个带有宏的excel工作簿,该宏能够进行搜索以找到具有该值的单元格并选择整行。 之后,它将复制该行并将其粘贴到名为“搜索”的电子表格中。
但是,我需要更改宏以在执行搜索之前将固定数量的列标题行(例如第1至4行)复制并粘贴到电子表格(“搜索”),然后复制并粘贴到同一电子表格(“搜索”)中。
谁能告诉我该怎么做? 我正在考虑这样做(选择,复制并粘贴然后搜索,选择,复制并粘贴)或选择多个范围,例如(选择第1至4行以及搜索后确定的行)。
Sub SearchForString()
Dim LSearchRow As Integer
Dim LCopyToRow As Integer
Dim LSearchValue As String
On Error GoTo Err_Execute
LSearchValue = InputBox("Please enter the staff ID.", "Enter value")
'Start search in row 5
LSearchRow = 6
'Start copying data to row 5 in Sheet1 (row counter variable)
LCopyToRow = 5
While Len(Range("A" & CStr(LSearchRow)).Value) > 0
'If value in column A = LSearchValue, copy entire row to Sheet1
If Range("A" & CStr(LSearchRow)).Value = LSearchValue Then
'Select row in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy
'Paste row into Sheet1 in next row
Sheets("Search").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
'Move counter to next row
LCopyToRow = LCopyToRow + 1
'Go back to Sheet1 to continue searching
Sheets("Search").Select
End If
LSearchRow = LSearchRow + 1
Wend
'Position on cell A3
Application.CutCopyMode = False
Range("A3").Select
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub
这是我的第一个答案,它只是整理您现有的代码。 我所有的更改和添加都用“ quote hash”标记。 研究我所做的更改,并尝试了解为什么要进行更改。 我计划另外两个答案。
Option Explicit '# Always include this statement at top
Sub SearchForString()
Dim LSearchRow As Long '# Integer creates 16-bit value which requires
Dim LCopyToRow As Long '# special processing on post-16-bit computers
Dim LSearchValue As String
Dim WshtSrc As Worksheet '# Faster and more convenient if you are
Dim WshtDest As Worksheet '# working with more than one worksheet
Set WshtSrc = Worksheets("Search") '# These are probably the wrong
Set WshtDest = Worksheets("Dest") '# worksheet names
'# I never use "On Error GoTo label" while developing macros because I want to
'# know where an error occurs. Before release, I check for every condition that
'# might lead to an error if possible. If I cannot stop the possibility of an
'# error, I will use "On Error Goto Next" and "On Error GoTo 0" either side of
'# a problem statement and I will then test Err. This will allows me to issue a
'# useful message to the user even if I cannot do better.
'# On Error GoTo Err_Execute
LSearchValue = InputBox("Please enter the staff ID.", "Enter value")
'Start search in row 5
LSearchRow = 6
'Start copying data to row 5 in Sheet1 (row counter variable)
LCopyToRow = 5
With WshtSrc
While Len(.Range("A" & CStr(LSearchRow)).Value) > 0 '#
'If value in column A = LSearchValue, copy entire row to Sheet1
If .Range("A" & CStr(LSearchRow)).Value = LSearchValue Then '#
.Rows(LSearchRow).Copy Destination:=WshtDest.Cells(LCopyToRow, 1)
'# 'Select row in Sheet1 to copy
'# Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
'# Selection.Copy
'# 'Paste row into Sheet1 in next row
'# Sheets("Search").Select
'# Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
'# ActiveSheet.Paste
'Move counter to next row
LCopyToRow = LCopyToRow + 1
'# 'Go back to Sheet1 to continue searching
'# Sheets("Search").Select
End If
LSearchRow = LSearchRow + 1
Wend
'Position on cell A3
'Range("A3").Select
End With
Exit Sub
'# Err_Execute:
'# MsgBox "An error occurred."
End Sub
答案2
在LSearchValue = InputBox("Please enter the staff ID.", "Enter value")
添加:
If LSearchValue = "" Or LSearchValue = "Enter value" Then
' User does not want to make a selection
Exit Sub
End If
WshtDest.Cells.EntireRow.Delete
'# Copy heading rows
WshtSrc.Rows("1:4").Copy Destination:=WshtDest.Range("A1")
我应该在第一个答案中包含前五行。 总是让用户说:“兄弟!我不是故意这样做的”,并摆脱他们所做的选择。 在开始新选择之前,我应该已经清除了先前选择的目标表。
最后的陈述是我知道复制四行的最简单方法。
我在第一个答案中发现一个错误。 我错过了两个必要的更改:
While Len(.Range("A" & CStr(LSearchRow)).Value) > 0
If .Range("A" & CStr(LSearchRow)).Value = LSearchValue Then
我省略了Range前面的句点。 Range
在活动工作表上运行。 .Range
在With
语句中指定的工作表上运行。
答案3
我在这个问题上不好,所以我是把水壶叫黑的锅。 使用Excel的力量。 如果Excel具有执行所需功能的功能,请使用它。
对于我的测试数据,我有四列,我的员工ID是字母A到D。要获取下面的宏,我:
。
Sub Macro2()
'
' Macro2 Macro
' Macro recorded 21/05/2014 by Tony Dallimore
'
'
Columns("A:D").Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:="B"
Selection.AutoFilter
End Sub
在第二个AutoFilter语句之后,如果用户选择职员ID B,则该屏幕几乎就是您要复制的内容。“几乎完全”是因为第2至4行不可见。 如果可以告诉自动筛选器您有四个标题行,那么我不知道,所以我将以另一种方式解决该问题。
宏记录器不知道您的目标。 该代码在语法上是正确的,但它不是很好的代码,因此必须进行整理。 另外,它不会复制行,因为我已经知道该怎么做。 下面的宏较小,如果您有很多行,则速度要快得多。
Sub SearchForString2()
Dim LSearchValue As String
Dim RngCopy As Range
Dim RngData As Range
Dim WshtSrc As Worksheet
Dim WshtDest As Worksheet
' I should have included this in answer 1. It stops the screen being repainted
' as the worksheets are changed which is both slow and irritating because of
' the flashing.
Application.ScreenUpdating = False
Set WshtSrc = Worksheets("Search") '# These are probably the wrong
Set WshtDest = Worksheets("Dest") '# worksheet names
LSearchValue = InputBox("Please enter the staff ID.", "Enter value")
WshtDest.Cells.EntireRow.ClearContents
If LSearchValue = "" Or LSearchValue = "Enter value" Then
' User does not want to make a selection
Exit Sub
End If
With WshtSrc
Set RngData = .Columns("A:D") ' Change column range as necessary
RngData.AutoFilter ' Switch AutoFilter on.
RngData.AutoFilter Field:=1, Criteria1:=LSearchValue
.Rows("2:4").Hidden = False
Set RngCopy = .Cells.SpecialCells(xlCellTypeVisible)
RngCopy.Copy Destination:=WshtDest.Range("A1")
RngData.AutoFilter ' Switch AutoFilter off.
End With
' Note that there is no period before RngData or RngCopy.
' When you set a range, the worksheet is part of the range.
' So Columns is a "child" of WshtSrc but RngData and RngCopy are not.
' The following statement shows that RngData "knows" what worksheet
'it applies to.
Debug.Print "RngData's worksheet: " & RngData.Worksheet.Name
Exit Sub
End Sub
您可以在搜索代码时使用以下代码:
Selection.Find(What:=LSearchValue, After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
True, SearchFormat:=False).Activate
Dim valuerow As Integer
valuerow = Application.ActiveCell.Row
valuerow
是找到的单元格的行索引
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.