VBA 将根据条件列表进行搜索和 copy/paste 的代码循环
VBA code loop that will search and copy/paste based on list of criteria
我有一个 sheet 数据超过 30 000 行，如果某个（例如“B”）行的列包含，我想将所有行复制到新的 excel 文件某些值（这些值的列表将在其他 sheet“代码”中）。
例如：
- 在sheet“代码”中，我在“A”列中有十个（甚至可能是 30 个）不同的数字（标准）。
- 开始搜索以复制所有行（在新的 excel 文件中），其中包含来自 sheet“代码”“A”列中的任何这些数字。
还不是很擅长VBA，但正在努力:)
感谢大家的帮助！
按多个条件过滤并导出到另一个工作簿
- 只是为了说明为什么这个问题不那么受欢迎。一道题有 50 个问题。
- 调整常量部分中的值，您应该可以开始了。
- “Sheet2”实际上是您的工作表“代码”。 “Sheet1”是第一个工作表。
代码
Option Explicit
Sub exportMultiToWorkbook()
' Error Handler
' Initialize error handling.
Const procName As String = "exportMultiToWorkbook"
On Error GoTo clearError ' Turn on error trapping.
' Constants
' Criteria
Const critName As String = "Sheet2"
Const critFirstCell As String = "A2"
' Source
Const srcName As String = "Sheet1"
Const srcFirstCell As String = "A1"
Const srcCritColumn As Long = 2
Dim wbs As Workbook
Set wbs = ThisWorkbook ' The workbook containing this code.
' Target
Const tgtFirstCell As String = "A1"
Dim tgtPath As String
' The same path as Source Workbook ('wbs'). Change if necessary.
tgtPath = wbs.Path & Application.PathSeparator & "Criteria"
' Other
Dim Success As Boolean
Dim AfterCop As Boolean
' Criteria
' Define Criteria Worksheet ('crit').
Dim crit As Worksheet
Set crit = wbs.Worksheets(critName)
' Define Criteria First Cell Range ('fcel').
Dim fcel As Range
Set fcel = crit.Range(critFirstCell)
' Define Criteria Processing Column Range ('pcr').
Dim pcr As Range
Set pcr = fcel.Resize(crit.Rows.Count - fcel.Row + 1)
' Define Criteria Last Non-Empty Cell Range ('lcel').
Dim lcel As Range
Set lcel = pcr.Find(What:="*", _
LookIn:=xlFormulas, _
SearchDirection:=xlPrevious)
' Validate Last Non-Empty Cell Range.
If lcel Is Nothing Then
GoTo ProcExit
End If
' Define Criteria Column Range ('cr').
Dim cr As Range
Set cr = crit.Range(fcel, lcel)
' Write values from Criteria Column Range to 1D Criteria Array ('Criteria'),
' probably using Criteria 2D Array ('Crit2D').
Dim Criteria As Variant
Dim i As Long
If cr.Rows.Count > 1 Then
' Criteria Column Range has multiple cells (rows).
' Write values from Criteria Range to Criteria 2D Array.
Dim Crit2D As Variant
Crit2D = cr.Value
' Write values from Criteria 2D Array to 1D Criteria Array.
ReDim Criteria(1 To UBound(Crit2D, 1))
For i = 1 To UBound(Crit2D)
Criteria(i) = CStr(Crit2D(i, 1)) ' AutoFilter prefers strings.
Next i
Else
' Criteria Column Range has one cell (row) only.
' Write the only value from Criteria Column Range to Criteria Array.
ReDim Criteria(1)
Criteria(1) = CStr(cr.Value) ' AutoFilter prefers strings.
End If
' Source
' Define Source Worksheet ('src').
Dim src As Worksheet
Set src = wbs.Worksheets(srcName)
' Define Source First Cell Range ('fcel').
Set fcel = src.Range(srcFirstCell)
' Define Source Last Cell Range ('lcel').
Set lcel = fcel.End(xlToRight).End(xlDown)
' Define Copy Range
Dim cop As Range
Set cop = src.Range(fcel, lcel)
' Turn off screen updating.
Application.ScreenUpdating = False
' Turn off filter, if on.
If src.FilterMode Then
cop.AutoFilter
End If
' Filter data. AutoFilter prefers the whole range.
cop.AutoFilter Field:=srcCritColumn, _
Criteria1:=Criteria, _
Operator:=xlFilterValues
' Enable the use of 'SafeExit' instead of 'ProcExit' after possible error.
AfterCop = True
' Target
' Add a new workbook.
With Workbooks.Add
' Copy Copy Range to the first sheet of a new workbook.
cop.Copy .Worksheets(1).Range(tgtFirstCell)
' I prefer to save this way; always a different file.
tgtPath = tgtPath & " " & Format(Now, "YYYYMMDD_HHMMSS")
.SaveAs Filename:=tgtPath, _
FileFormat:=xlOpenXMLWorkbook ' i.e. ".xlsx"
' If you prefer the file to have the same name and for it to be
' overwritten without Excel complaining, then rather use the following:
' Application.DisplayAlerts = False
' .SaveAs Filename:=tgtPath, _
' FileFormat:=xlOpenXMLWorkbook ' i.e. ".xlsx"
' Application.DisplayAlerts = True
.Close
End With
Success = True
SafeExit:
' Source
' Turn off filter.
cop.AutoFilter
wbs.Saved = True
' Turn on screen updating.
Application.ScreenUpdating = True
ProcExit:
' Inform user.
If Success Then
MsgBox Prompt:="Created file '" & tgtPath & "'.", _
Buttons:=vbInformation, _
Title:="Multiple Criteria Filter - Success"
Else
MsgBox Prompt:="Could not finish task.", _
Buttons:=vbCritical, _
Title:="Multiple Criteria Filter - Fail"
End If
Exit Sub
clearError:
Debug.Print "'" & procName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
If Not AfterCop Then
GoTo ProcExit
Else
GoTo SafeExit
End If
End Sub
我知道您是新来的，不想阻止您以后寻求帮助。请尝试在未来提出更具体的问题。例如，您可能会问如何确定一个单元格的值是否与一系列单元格中任何单元格的值匹配。也就是说，我觉得你不知道从哪里开始，所以我试一试。 VBasic 2008 已经提供了一个很好的答案，并且实际上为您编写了代码，这是您不应该期望的。 VBasic 2008 的代码很棒，但比您需要的要多，对于初学者来说也有点难以理解。在下面的代码中，您实际上只需要修改 CopyFilteredDemo 过程中的三个“设置”行。
下面是简单的代码，它做了几个简化的假设。根据您的要求，我认为这可以满足您的需求。如果没有，请添加更多特异性。下面列出的假设的许多限制很容易克服，但我不想为此编写代码。
- 源工作簿和目标工作簿相同，或者都已打开。 （我只在同一工作簿中测试了不同的 sheet，但它应该可以跨工作簿工作。）
- 源作品和目标作品sheet不同。如果它们相同，则会故意引发错误。
- 目标工作sheet 已经存在。
$) desitnation worksheet 将被完全清除和覆盖。 CopyFilteredDemo中将True改为False以便通过，以便将False传递给CopyFiltered。
- 仅在源范围的第一列中搜索筛选范围中的完全匹配项。由于复制了整行，因此将哪一列设置为 fromRange 中的第一列并不重要。只需选择您希望与 filterRange 中的值进行比较的列。
- 如果没有过滤掉，整个作品sheet行将被复制。
- 筛选条件中没有重复项。我还没有测试过它是否会导致目标工作重复sheet。
- 未对数千行进行性能测试。如果您发现问题，请先设置 Application.ScreenUpdating = False。最后再打开它。确保您有错误处理以在发生错误时重新打开。否则屏幕更新将保持关闭状态，您会发现这是非常不受欢迎的。如果这超出了您当前的舒适度，请不要禁用 ScreenUpdating。
作为大纲，主要过程是 CopyFiltered，它将数据从一个 sheet 复制到另一个。此过程调用 IsInRange 函数，如果参数 valueToFind 与参数 RangeToSearch 指定的范围内的值完全匹配，则该函数 returns 为真。因此，在比较源范围 (fromRange) 和过滤条件 (filterRange) 时，会比较 fromRange 的第一列。 fromRange 不确定要复制哪些列，因为您请求复制整行。而 fromRange 有两个目的。首先，它确定要复制的行。其次，将 fromRange 的第一列与 filterRange 进行比较以进行匹配。
我在代码中放了很多注释，所以我希望它相对容易理解。
Option Explicit
' Option Explicit must be the first line of code in the module.
' It forces you to declare every variable. It may seem a nuisance
' to a beginner, but you will quickly learn its value. It will
' keep you from spelling the same variable two ways and failing
' to understand why your code failed. There are other benefits
' that you'll pick up over time, such as conserving memory and
' forcing data typing.
Public Function IsInRange(ByVal valueToFind, ByVal RangeToSearch As Range)
' If any cell in RangeToSearch = valueToFind, return True
' Else return False.
Dim x
' If valueToFind is not in RangeToSearch, expect
' error 91. That's okay, we'll handle that error
' and return False. If we get a differnt error,
' we'll raise it.
On Error GoTo EH
x = RangeToSearch.Find(valueToFind)
On Error GoTo 0
' If we made it this far, we found it!
IsInRange = True
Exit Function
EH:
If Err.Number = 91 Then
' this error is expected if valueToFind is not in RangeToSearch
IsInRange = False
Err.Clear
Else
' Unexpected error.
Err.Raise Number:=Err.Number, Source:=Err.Source _
, Description:=Err.Description
End If
End Function
Sub CopyFiltered(ByVal fromRange As Range, ByVal toRange As Range _
, ByVal filterRange As Range _
, Optional clearFirst As Boolean = True)
' Arguments:
' fromRange: the full range from which to copy
' toRange: the top left cell fromRange will be pasted to the
' top left cell of toRange. The size of toRange
' is irrelevant. Only the top left cell is used
' for reference.
' fitlerRange: a range containing values with which to filter.
' clearFirst: if True, clear all content from range containing
' toRange before pasting new values.
Dim rng As Range, rowOffset As Integer
Dim rowNum As Integer, colNum As Integer, i As Integer
Dim errMsg As String, cell As Range
Set toRange = toRange.Cells(1, 1)
Set fromRange = fromRange.Columns(1)
' If fromRange and toRange are on the same worksheet,
' raise an exception.
If fromRange.Worksheet.Name = toRange.Worksheet.Name Then
errMsg = "fromRange and toRange cannot be on the same worksheet."
Err.Raise 1000, "CopyFiltered", errMsg
Exit Sub
End If
' Clear all content from the destination worksheet.
toRange.Worksheet.Cells.ClearContents
'
' Loop through each row of fromRange
rowOffset = -1
For i = 1 To fromRange.Rows.Count
Set cell = fromRange.Cells(i, 1)
Debug.Print cell.Address
' If the the cell in the first column of fromRange
' exaclty equals any cell in filterRange, proceed.
If IsInRange(cell.Value, filterRange) Then
' Add one to rowOffset, so we copy this row
' below the last pasted row of the sheet
' containing toRange
rowOffset = rowOffset + 1
cell.EntireRow.Copy toRange.Offset(rowOffset, 0).EntireRow
End If
Next i
End Sub
Sub CopyFilteredDemo()
Dim fromRange As Range, toRange As Range, filterRange As Range
' Set our to, from and filter ranges
Set fromRange = Sheets("Sheet1").Range("c10:c40")
Set toRange = Sheets("Sheet2").Range("A2")
Set filterRange = Sheets("Sheet1").Range("B2:B6")
' Run our filtered copy procedure.
CopyFiltered fromRange, toRange, filterRange, True
End Sub
我有一个 sheet 数据超过 30 000 行，如果某个（例如“B”）行的列包含，我想将所有行复制到新的 excel 文件某些值（这些值的列表将在其他 sheet“代码”中）。 例如：
- 在sheet“代码”中，我在“A”列中有十个（甚至可能是 30 个）不同的数字（标准）。
- 开始搜索以复制所有行（在新的 excel 文件中），其中包含来自 sheet“代码”“A”列中的任何这些数字。
还不是很擅长VBA，但正在努力:) 感谢大家的帮助！
按多个条件过滤并导出到另一个工作簿
- 只是为了说明为什么这个问题不那么受欢迎。一道题有 50 个问题。
- 调整常量部分中的值，您应该可以开始了。
- “Sheet2”实际上是您的工作表“代码”。 “Sheet1”是第一个工作表。
代码
Option Explicit
Sub exportMultiToWorkbook()
' Error Handler
' Initialize error handling.
Const procName As String = "exportMultiToWorkbook"
On Error GoTo clearError ' Turn on error trapping.
' Constants
' Criteria
Const critName As String = "Sheet2"
Const critFirstCell As String = "A2"
' Source
Const srcName As String = "Sheet1"
Const srcFirstCell As String = "A1"
Const srcCritColumn As Long = 2
Dim wbs As Workbook
Set wbs = ThisWorkbook ' The workbook containing this code.
' Target
Const tgtFirstCell As String = "A1"
Dim tgtPath As String
' The same path as Source Workbook ('wbs'). Change if necessary.
tgtPath = wbs.Path & Application.PathSeparator & "Criteria"
' Other
Dim Success As Boolean
Dim AfterCop As Boolean
' Criteria
' Define Criteria Worksheet ('crit').
Dim crit As Worksheet
Set crit = wbs.Worksheets(critName)
' Define Criteria First Cell Range ('fcel').
Dim fcel As Range
Set fcel = crit.Range(critFirstCell)
' Define Criteria Processing Column Range ('pcr').
Dim pcr As Range
Set pcr = fcel.Resize(crit.Rows.Count - fcel.Row + 1)
' Define Criteria Last Non-Empty Cell Range ('lcel').
Dim lcel As Range
Set lcel = pcr.Find(What:="*", _
LookIn:=xlFormulas, _
SearchDirection:=xlPrevious)
' Validate Last Non-Empty Cell Range.
If lcel Is Nothing Then
GoTo ProcExit
End If
' Define Criteria Column Range ('cr').
Dim cr As Range
Set cr = crit.Range(fcel, lcel)
' Write values from Criteria Column Range to 1D Criteria Array ('Criteria'),
' probably using Criteria 2D Array ('Crit2D').
Dim Criteria As Variant
Dim i As Long
If cr.Rows.Count > 1 Then
' Criteria Column Range has multiple cells (rows).
' Write values from Criteria Range to Criteria 2D Array.
Dim Crit2D As Variant
Crit2D = cr.Value
' Write values from Criteria 2D Array to 1D Criteria Array.
ReDim Criteria(1 To UBound(Crit2D, 1))
For i = 1 To UBound(Crit2D)
Criteria(i) = CStr(Crit2D(i, 1)) ' AutoFilter prefers strings.
Next i
Else
' Criteria Column Range has one cell (row) only.
' Write the only value from Criteria Column Range to Criteria Array.
ReDim Criteria(1)
Criteria(1) = CStr(cr.Value) ' AutoFilter prefers strings.
End If
' Source
' Define Source Worksheet ('src').
Dim src As Worksheet
Set src = wbs.Worksheets(srcName)
' Define Source First Cell Range ('fcel').
Set fcel = src.Range(srcFirstCell)
' Define Source Last Cell Range ('lcel').
Set lcel = fcel.End(xlToRight).End(xlDown)
' Define Copy Range
Dim cop As Range
Set cop = src.Range(fcel, lcel)
' Turn off screen updating.
Application.ScreenUpdating = False
' Turn off filter, if on.
If src.FilterMode Then
cop.AutoFilter
End If
' Filter data. AutoFilter prefers the whole range.
cop.AutoFilter Field:=srcCritColumn, _
Criteria1:=Criteria, _
Operator:=xlFilterValues
' Enable the use of 'SafeExit' instead of 'ProcExit' after possible error.
AfterCop = True
' Target
' Add a new workbook.
With Workbooks.Add
' Copy Copy Range to the first sheet of a new workbook.
cop.Copy .Worksheets(1).Range(tgtFirstCell)
' I prefer to save this way; always a different file.
tgtPath = tgtPath & " " & Format(Now, "YYYYMMDD_HHMMSS")
.SaveAs Filename:=tgtPath, _
FileFormat:=xlOpenXMLWorkbook ' i.e. ".xlsx"
' If you prefer the file to have the same name and for it to be
' overwritten without Excel complaining, then rather use the following:
' Application.DisplayAlerts = False
' .SaveAs Filename:=tgtPath, _
' FileFormat:=xlOpenXMLWorkbook ' i.e. ".xlsx"
' Application.DisplayAlerts = True
.Close
End With
Success = True
SafeExit:
' Source
' Turn off filter.
cop.AutoFilter
wbs.Saved = True
' Turn on screen updating.
Application.ScreenUpdating = True
ProcExit:
' Inform user.
If Success Then
MsgBox Prompt:="Created file '" & tgtPath & "'.", _
Buttons:=vbInformation, _
Title:="Multiple Criteria Filter - Success"
Else
MsgBox Prompt:="Could not finish task.", _
Buttons:=vbCritical, _
Title:="Multiple Criteria Filter - Fail"
End If
Exit Sub
clearError:
Debug.Print "'" & procName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
If Not AfterCop Then
GoTo ProcExit
Else
GoTo SafeExit
End If
End Sub
我知道您是新来的，不想阻止您以后寻求帮助。请尝试在未来提出更具体的问题。例如，您可能会问如何确定一个单元格的值是否与一系列单元格中任何单元格的值匹配。也就是说，我觉得你不知道从哪里开始，所以我试一试。 VBasic 2008 已经提供了一个很好的答案，并且实际上为您编写了代码，这是您不应该期望的。 VBasic 2008 的代码很棒，但比您需要的要多，对于初学者来说也有点难以理解。在下面的代码中，您实际上只需要修改 CopyFilteredDemo 过程中的三个“设置”行。
下面是简单的代码，它做了几个简化的假设。根据您的要求，我认为这可以满足您的需求。如果没有，请添加更多特异性。下面列出的假设的许多限制很容易克服，但我不想为此编写代码。
- 源工作簿和目标工作簿相同，或者都已打开。 （我只在同一工作簿中测试了不同的 sheet，但它应该可以跨工作簿工作。）
- 源作品和目标作品sheet不同。如果它们相同，则会故意引发错误。
- 目标工作sheet 已经存在。 $) desitnation worksheet 将被完全清除和覆盖。 CopyFilteredDemo中将True改为False以便通过，以便将False传递给CopyFiltered。
- 仅在源范围的第一列中搜索筛选范围中的完全匹配项。由于复制了整行，因此将哪一列设置为 fromRange 中的第一列并不重要。只需选择您希望与 filterRange 中的值进行比较的列。
- 如果没有过滤掉，整个作品sheet行将被复制。
- 筛选条件中没有重复项。我还没有测试过它是否会导致目标工作重复sheet。
- 未对数千行进行性能测试。如果您发现问题，请先设置 Application.ScreenUpdating = False。最后再打开它。确保您有错误处理以在发生错误时重新打开。否则屏幕更新将保持关闭状态，您会发现这是非常不受欢迎的。如果这超出了您当前的舒适度，请不要禁用 ScreenUpdating。
作为大纲，主要过程是 CopyFiltered，它将数据从一个 sheet 复制到另一个。此过程调用 IsInRange 函数，如果参数 valueToFind 与参数 RangeToSearch 指定的范围内的值完全匹配，则该函数 returns 为真。因此，在比较源范围 (fromRange) 和过滤条件 (filterRange) 时，会比较 fromRange 的第一列。 fromRange 不确定要复制哪些列，因为您请求复制整行。而 fromRange 有两个目的。首先，它确定要复制的行。其次，将 fromRange 的第一列与 filterRange 进行比较以进行匹配。
我在代码中放了很多注释，所以我希望它相对容易理解。
Option Explicit
' Option Explicit must be the first line of code in the module.
' It forces you to declare every variable. It may seem a nuisance
' to a beginner, but you will quickly learn its value. It will
' keep you from spelling the same variable two ways and failing
' to understand why your code failed. There are other benefits
' that you'll pick up over time, such as conserving memory and
' forcing data typing.
Public Function IsInRange(ByVal valueToFind, ByVal RangeToSearch As Range)
' If any cell in RangeToSearch = valueToFind, return True
' Else return False.
Dim x
' If valueToFind is not in RangeToSearch, expect
' error 91. That's okay, we'll handle that error
' and return False. If we get a differnt error,
' we'll raise it.
On Error GoTo EH
x = RangeToSearch.Find(valueToFind)
On Error GoTo 0
' If we made it this far, we found it!
IsInRange = True
Exit Function
EH:
If Err.Number = 91 Then
' this error is expected if valueToFind is not in RangeToSearch
IsInRange = False
Err.Clear
Else
' Unexpected error.
Err.Raise Number:=Err.Number, Source:=Err.Source _
, Description:=Err.Description
End If
End Function
Sub CopyFiltered(ByVal fromRange As Range, ByVal toRange As Range _
, ByVal filterRange As Range _
, Optional clearFirst As Boolean = True)
' Arguments:
' fromRange: the full range from which to copy
' toRange: the top left cell fromRange will be pasted to the
' top left cell of toRange. The size of toRange
' is irrelevant. Only the top left cell is used
' for reference.
' fitlerRange: a range containing values with which to filter.
' clearFirst: if True, clear all content from range containing
' toRange before pasting new values.
Dim rng As Range, rowOffset As Integer
Dim rowNum As Integer, colNum As Integer, i As Integer
Dim errMsg As String, cell As Range
Set toRange = toRange.Cells(1, 1)
Set fromRange = fromRange.Columns(1)
' If fromRange and toRange are on the same worksheet,
' raise an exception.
If fromRange.Worksheet.Name = toRange.Worksheet.Name Then
errMsg = "fromRange and toRange cannot be on the same worksheet."
Err.Raise 1000, "CopyFiltered", errMsg
Exit Sub
End If
' Clear all content from the destination worksheet.
toRange.Worksheet.Cells.ClearContents
'
' Loop through each row of fromRange
rowOffset = -1
For i = 1 To fromRange.Rows.Count
Set cell = fromRange.Cells(i, 1)
Debug.Print cell.Address
' If the the cell in the first column of fromRange
' exaclty equals any cell in filterRange, proceed.
If IsInRange(cell.Value, filterRange) Then
' Add one to rowOffset, so we copy this row
' below the last pasted row of the sheet
' containing toRange
rowOffset = rowOffset + 1
cell.EntireRow.Copy toRange.Offset(rowOffset, 0).EntireRow
End If
Next i
End Sub
Sub CopyFilteredDemo()
Dim fromRange As Range, toRange As Range, filterRange As Range
' Set our to, from and filter ranges
Set fromRange = Sheets("Sheet1").Range("c10:c40")
Set toRange = Sheets("Sheet2").Range("A2")
Set filterRange = Sheets("Sheet1").Range("B2:B6")
' Run our filtered copy procedure.
CopyFiltered fromRange, toRange, filterRange, True
End Sub