根据条件将行复制到另一个工作表的 VBA 代码
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/44742564/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
VBA Code to copy rows based on criteria to another sheet
提问by Sreeni Vasan
I am trying to write a simple VBA code to pick up complete rows from one sheet and copy them to another sheet based o certain criteria
我正在尝试编写一个简单的 VBA 代码来从一张纸中提取完整的行，然后根据某些标准将它们复制到另一张纸上
For example if the first cell in a row contains the text "Cricket" (case insensitive), the system will create a worksheet with the name Cricket, and will copy all rows that fit the criteria to the new worksheet
例如，如果一行中的第一个单元格包含文本“Cricket”（不区分大小写），系统将创建一个名为 Cricket 的工作表，并将所有符合条件的行复制到新工作表中
Below is my attempt, however it's not working as expected
以下是我的尝试，但它没有按预期工作
Sub officetest()
Worksheets("Sheet1").Activate
If Range("A1,A10000") = "Cricket" Then
Sheets.Add
Sheets(2).Name = "Cricket"
Worksheets("Sheet1").Range("A1, A10000").Copy
Worksheets("Sheet2").Range("A1")
End If
End Sub
tried this as well..but not working:
也试过这个..但不起作用：
Sub officetest()
Worksheets(1).Activate
If Range("A1,A10000") = "Cricket" Then
Sheets.Add Sheets(1).Name = "Cricket"
Worksheets("Cricket").Range("A, AD").Copy Worksheets(2).Range("A1")
End If
End Sub
回答by jsotola
this is a recorded macro:
这是一个录制的宏：
i filled first few cells in column A with text (on a blank worksheet)
我用文本填充了 A 列中的前几个单元格（在空白工作表上）
made one of the cells "cricket"
使其中一个细胞“蟋蟀”
started macro recorder
启动宏记录器
selected top left cell ... searched for "cricket" (searched by columns)
选定的左上角单元格...搜索“板球”（按列搜索）
created a new worksheet and named it "cricket"
创建了一个新工作表并将其命名为“板球”
returned to first sheet selected row with "cricket" ... hit ctrl-c (copy)
使用“板球”返回到第一张选定的行...点击 ctrl-c（复制）
selected cricket worksheet ... hit ctrl-v (paste)
选定的板球工作表...点击 ctrl-v（粘贴）
stopped macro recorder
停止宏记录器
this is the resulting macro:
这是由此产生的宏：
Sub Macro2()
Cells.Find(What:="cricket", After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Selection.Copy
Sheets.Add After:=ActiveSheet
Sheets("Sheet2").Select
Sheets("Sheet2").Name = "cricket"
Sheets("Sheet1").Select
Rows("9:9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("cricket").Select
ActiveSheet.Paste
End Sub
here is a quick range addressing example
这是一个快速范围寻址示例
there are sooooo many ways to refer to a cell and to cell ranges in excel
有很多方法可以在excel中引用单元格和单元格范围
i included it because, in the rewritten code, the found cell row is referred to as row one
我包含它是因为在重写的代码中，找到的单元格行被称为第一行
Sub lesson()
' note: use F8 to single-step through code
' quick example of ranges "inside" other ranges
Range("b3").Select ' cell at B3 is selected
Range("b3").Range("a2").Select ' cell at B4 is selected because range(B3) is now a top corner for range(a2)
Range("b3").Range("a1", "b2").Select ' range(b3:c4) is selected
End Sub
' _A_ _B_ _C_
'1| | | |
' |_ _|_ _|_ _|
'2| | | |
' |_ _|_ _|_ _|
'3| |A1 |B1 | <<<<< range("B3").Range("A1", "B2")
' |_ _|_ _|_ _|
'4| |A2 |B2 | cell "B3" is the top left corner of Range("A1", "B2")
' |_ _|_ _|_ _|
'5| | | |
' |_ _|_ _|_ _|
here is the recorded macro that has been rewritten to make it shorter
这是已被重写以使其更短的录制宏
the code has no error checking, so it will crash if search text is not found
代码没有错误检查，所以如果没有找到搜索文本，它会崩溃
you can uncomment the "select" methods then single-step through the code and see which cells are highlighted by the select statement
您可以取消对“select”方法的注释，然后单步执行代码并查看 select 语句突出显示了哪些单元格
note of caution: "foundHere.Select" method will fail if you do not have the first sheet selected (a select method will fail if you try to select a range that is not on an active worksheet
注意事项：如果您没有选择第一个工作表，“foundHere.Select”方法将失败（如果您尝试选择不在活动工作表上的范围，选择方法将失败
Sub findAndCopy()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim foundHere As Range
Dim findMe As String
findMe = "cricket"
Set foundHere = Cells.Find(What:=findMe, After:=Sheets("sheet1").Range("a1"), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
' foundHere.Select ' use during debugging only to see if correct cell is being acted on
' foundHere.Range("1:1").Select
wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count)).Name = findMe
' note: range("1:1") is first row of range(foundHere) ... see above
foundHere.Range("1:1").Copy Sheets(findMe).Rows(5) ' copy to row 5 (adjust to your liking)
End Sub
i hope that this helps you get started
我希望这可以帮助您入门
回答by paul bica
Copy both of these procedures in a new VBA module and execute "CopyRows()"
将这两个过程复制到新的 VBA 模块中并执行“CopyRows()”
First sub will filter all rows using Cricket as the criteria in the first column
First sub 将使用 Cricket 作为第一列中的条件过滤所有行
Then it will copy all visible rows to the new Sheet named Cricket
然后它将所有可见行复制到名为 Cricket 的新工作表
Option Explicit
Public Sub CopyRows()
Const ITEM1 As String = "Cricket"
Dim wsFrom As Worksheet, wsDest As Worksheet
Set wsFrom = Sheet1 '<--- Update this
Application.ScreenUpdating = False
Set wsDest = CheckNamedSheet(ITEM1)
With wsFrom.UsedRange
.AutoFilter Field:=1, Criteria1:="=" & ITEM1
.Copy 'Copy visible data
End With
With wsDest.Cells
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteAll
.Cells(1, 1).Copy
End With
Application.CutCopyMode = False
wsFrom.UsedRange.AutoFilter
Application.ScreenUpdating = True
End Sub
This function checks if a previous Sheet named Cricket exists, deletes it and creates a new one
此函数检查之前名为 Cricket 的工作表是否存在，将其删除并创建一个新工作表
Private Function CheckNamedSheet(ByVal sheetName As String) As Worksheet
Dim ws As Worksheet, result As Boolean, activeWS As Worksheet
Set activeWS = IIf(ActiveSheet.Name = sheetName, Worksheets(1), ActiveSheet)
For Each ws In Worksheets
If ws.Name = sheetName Then
Application.DisplayAlerts = False
ws.Delete 'delete sheet if it already exists
Application.DisplayAlerts = True
Exit For
End If
Next
Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count)) 'create a new one
ws.Name = sheetName
activeWS.Activate
Set CheckNamedSheet = ws
End Function
回答by jsotola
this is just an experiment. i included it because i used it when i needed to figure out "offset" addressing
这只是一个实验。我包含它是因为我在需要找出“偏移”寻址时使用它
it may help someone in the future
它可能会在未来帮助某人
Sub see_how_offset_works()
Range("c5").Select ' C5
Range("c5").offset(-1).Select ' C4 previous row
Range("c5").offset(0).Select ' C5 same row
Range("c5").offset(1).Select ' C6 next row
Range("c5").offset(1, 1).Select ' D6 next row and next column
End Sub
here is code that may work for you
这是可能对您有用的代码
i have not thoroughly tested the code, and there may be issues because i have not "destroyed" any of the created objects eg. set wb = Nothing
我没有彻底测试代码，可能会出现问题，因为我没有“破坏”任何创建的对象，例如。 设置 wb = 无
there is no check for sheet name duplication
没有检查工作表名称重复
the program assembles all the data ranges of interest into one range and then does a single copy command to put the data where it is needed
该程序将所有感兴趣的数据范围组装到一个范围内，然后执行单个复制命令将数据放在需要的地方
enjoy
请享用
'
Sub testFind() ' !!!!!!!!!!!! run me !!!!!!!!!!!!
If findData("cricket") Then
MsgBox "success"
Else
MsgBox "text not found"
End If
End Sub
' ----------------------------------------------------
Function findData(findme As String) As Boolean ' returns True if search is successful
Dim wb As Workbook
Set wb = ThisWorkbook
Dim start As Range
Dim fini As Range
Dim oneFound As Range
Dim allFound As Range
Set start = Range("a1") ' top of the search range (must be one column)
Set fini = Range("a20") ' bottom of the search range (must be one column)
' Range(start, fini).Select ' highlight initial search area (debug only ... comment out after debug done)
Dim indx As Integer
indx = 0 ' how far down within the search range do we start the next search
Dim i As Integer ' loop counter
Dim foundAt As Integer ' row number where text has been found (this is relative to search range, not relative to worksheet)
Dim numFinds As Integer ' how many times is the search text repeated
numFinds = Application.WorksheetFunction.CountIf(Range(start, fini), findme) ' count occurences
' Debug.Print numFinds
findData = False ' preload the "failure" status
If numFinds > 0 Then
For i = 1 To numFinds
foundAt = Application.WorksheetFunction.Match(findme, Range(start.offset(indx), fini), 0)
indx = indx + foundAt - 1 ' indx is the offset from "original top of search range" to the "current found cell"
start.offset(indx).Select ' for debugging ... "start.offset(indx)" is the "current found cell"
Set oneFound = Rows(start.offset(indx).Row) ' whole row
' Set oneFound = start.offset(indx).Range("b1:f1") ' cells in columns B:F
' oneFound.Select ' for debugging only
If i = 1 Then
Set allFound = oneFound
Else
Set allFound = Union(allFound, oneFound) ' assemble all ranges into one range
End If
' allFound.Select ' for debugging only
indx = indx + 1 ' point to next cell after the "current found cell"
Next
' allFound.Select ' for debugging only
' allFound.Copy Rows(22) ' copy selected ranges into row 22 of the current worksheet
wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count)).Name = findme ' this new sheet will have focus
allFound.Copy Sheets(findme).Rows(5) ' copy to row 5 (change to your liking)
findData = True ' success status
End If
End Function
