提问人：Achilles 提问时间：8/11/2023 更新时间：8/11/2023 访问量：38
通过带有条件的VBA将Excel单元格数据从一列移动到另一列
Move Excel cell data from one column to another via VBA with a condition
问：
我在 B 列中有文本。我使用的条件是，如果 B 列中的文本为“TEST”，则将 E&F 列中的现有数据分别移动到 M&N 列并清除源单元格。如果我的范围很小，它就会起作用。但是当我扩大范围时，它不做任何事情，也不会返回错误。范围大吗？我基本上正在浏览从 B2：B15000 开始的所有 B 列，但对于这里的情况，我只搜索了 B2：B4000，它仍然什么也没做。较小的范围，如扫描 100 个细胞，没有问题。
例如，如果它在单元格 B2、B55 和 B56 中找到“TEST”，则现有数据会发生这种情况：
E2 移至 M2： E2 内容已清除： F2 移至 N2： 清除 F2 内容：
E55 移至 M55： 已清除的 E55 内容： F55 移至 N55： F55 内容被清除：
E56 移至 M56： 已清除的 E56 内容： F56 移至 N56： 清除 F56 内容：
Sub MoveIt2()
If Range("B2:B4000").Cells(i, 1).Value = "TEST" Then
With ActiveSheet
.Range("E2:E4000").Copy
.Range("M2:M4000").Insert Shift:=xlToRight
.Range("E2:E4000").ClearContents
.Range("F2:F4000").Copy
.Range("N2:N4000").Insert Shift:=xlToRight
.Range("F2:F4000").ClearContents
End With
End If
Application.CutCopyMode = False
End Sub
答：
1赞
VBasic2008
8/11/2023
#1
复制-插入行范围
Sub MoveIt2()
' Define constants.
Const SRC_LOOKUP_FIRST_CELL As String = "B2"
Const SRC_COPY_COLUMNS As String = "E:F"
Const DST_INSERT_COLUMN As String = "M"
Const LOOKUP_STRING As String = "Test"
' Reference the worksheet.
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
' Reference the source lookup range.
Dim slrg As Range:
With ws.Range(SRC_LOOKUP_FIRST_CELL)
Set slrg = ws.Range(.Cells, ws.Cells(ws.Rows.Count, .Column).End(xlUp))
End With
' Reference the source copy range.
Dim scrg As Range: Set scrg = slrg.EntireRow.Columns(SRC_COPY_COLUMNS)
' Combine each copy-row into the source union range.
Dim surg As Range, cell As Range, r As Long, CellString As String
For Each cell In slrg.Cells
r = r + 1
CellString = CStr(cell.Value)
If StrComp(CellString, LOOKUP_STRING, vbTextCompare) = 0 Then ' is equal
If surg Is Nothing Then ' first
Set surg = scrg.Rows(r)
Else ' all but first
Set surg = Union(surg, scrg.Rows(r))
End If
'Else ' is not equal; do nothing
End If
Next cell
If surg Is Nothing Then Exit Sub
' Using the column offset, reference the destination union range.
Dim ColumnOffset As Long:
ColumnOffset = ws.Columns(DST_INSERT_COLUMN).Column - scrg.Column
Dim durg As Range: Set durg = surg.Offset(, ColumnOffset)
' Insert.
Application.ScreenUpdating = False
durg.Insert Shift:=xlToRight
' Copy the source union rows to the destination union rows.
Dim sarg As Range
For Each sarg In surg.Areas
' Copy values only (fast).
sarg.Offset(, ColumnOffset).Value = sarg.Value
' Copy formulas and formats (slow).
'sarg.Copy sarg.Offset(, ColumnOffset)
Next sarg
' Clear the contents in the source union range.
surg.ClearContents
Application.ScreenUpdating = True
' Inform.
MsgBox "MoveIt2 has finished.", vbInformation
End Sub
评论