我正在尝试编写一个简单的VBA代码，从一张纸上拾取完整的行，然后根据某些标准将它们复制到另一张纸上
例如，如果一行中的第一个单元格包含文本＆＃34; Cricket＆＃34; （不区分大小写），系统将创建一个名为Cricket的工作表，并将符合条件的所有行复制到新工作表
以下是我的尝试，但是它没有按预期工作
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
尝试了这个..但是没有工作：
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
答案 0 :(得分：0)
这是录制的宏：
我在文章A中填写了前几个单元格（在空白工作表上）
制作了一个单元格＆＃34;板球＆＃34;
启动宏录制器
选择左上角的单元格...搜索＆＃34;板球＆＃34; （按列搜索）
创建了一个新的工作表并将其命名为＆＃34; cricket＆＃34;
使用＆＃34; cricket＆＃34;返回第一张选定的行...点击ctrl-c（复制）
选择的板球工作表...点击ctrl-v（粘贴）
停止宏录制器
这是结果宏：
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
这是一个快速范围寻址示例
在excel
中有很多方法可以引用单元格和单元格区域我把它包括在内，因为在重写的代码中，找到的单元格行被称为第一行
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| | | |
' |_ _|_ _|_ _|
这里是已经重写的录制宏 缩短
代码没有错误检查，因此如果找不到搜索文本则会崩溃
您可以取消注释＆＃34;选择＆＃34;方法 然后单步执行代码并查看select语句突出显示哪些单元格
注意事项：＆＃34;找到了这里。选择＆＃34;如果您没有选择第一张纸，方法将失败 （如果您尝试选择不在活动工作表上的范围，则选择方法将失败
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
我希望这有助于你开始
答案 1 :(得分：0)
在新的VBA模块中复制这两个程序并执行＆＃34; CopyRows（）＆＃34;
First sub将使用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
此函数检查前一个名为Cricket的Sheet是否存在，删除它并创建一个新的
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
答案 2 :(得分：0)
这只是一个实验。我把它包括在内，因为当我需要弄清楚＆＃34;偏移＆＃34;寻址
它可能会帮助将来的某个人
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
这里有可能适合你的代码
我没有对代码进行彻底的测试，可能会出现问题，因为我没有＆＃34;销毁＆＃34;任何创建的对象 例如。 设置wb = Nothing
没有检查工作表名称重复
程序将所有感兴趣的数据范围组合到一个范围内，然后执行单个复制命令将数据放入需要的位置
享受
'
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