英文:
Move Excel cell data from one column to another via VBA with a condition
问题
我有列B中的文本。我正在使用条件，如果列B中的文本为“TEST”，那么我将现有数据移动到列M和N中，分别清除源单元格。如果我的范围很小，它可以正常工作。但是当我扩展范围时，它不起作用，也不返回错误。范围是否太大？我基本上正在查看所有的B列，范围从B2到B15000，但在这种情况下，我只在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()
For i = 2 To 4000
If Range("B" & i).Value = "TEST" Then
With ActiveSheet
.Range("E" & i).Copy
.Range("M" & i).Insert Shift:=xlToRight
.Range("E" & i).ClearContents
.Range("F" & i).Copy
.Range("N" & i).Insert Shift:=xlToRight
.Range("F" & i).ClearContents
End With
End If
Next i
Application.CutCopyMode = False
End Sub
这是一个修正后的VBA代码，用于处理范围B2到B4000中的数据。请确保将此代码放入正确的Excel宏模块中以运行它。
英文:
I've got text in column B. I'm using a condition that if the text in Column B is "TEST", then I'm moving the existing data in column E&F to columns M&N, respectively and clearing the source cells. It works if my range is small. But when I expand the range, it does not do anything and does not return an error. Is the range to large? I'm basically looking through all of column B which ranges from B2:B15000 but for the case here, I'm only searching through B2:B4000 and it still does nothing. Smaller range like scanning 100 cells works with no issue.
For example, if it finds "TEST" in cells B2, B55 and B56, then this happens to the existing data:
E2 gets moved to M2:
E2 contents is cleared:
F2 gets moved to N2:
F2 contents is cleared:
E55 get moved to M55:
E55 contents in cleared:
F55 gets moved to N55:
F55 contents is cleared:
E56 get moved to M56:
E56 contents in cleared:
F56 gets moved to N56:
F56 contents is cleared:
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
得分: 1
Sub MoveIt2()
' 定义常量。
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"
' 引用工作表。
Dim ws As Worksheet: Set ws = ActiveSheet ' 改进！
' 引用源查找范围。
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
' 引用源复制范围。
Dim scrg As Range: Set scrg = slrg.EntireRow.Columns(SRC_COPY_COLUMNS)
' 将每个复制行合并到源联合范围中。
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 ' 相等
If surg Is Nothing Then ' 第一个
Set surg = scrg.Rows(r)
Else ' 除第一个之外的所有
Set surg = Union(surg, scrg.Rows(r))
End If
'Else ' 不相等，不做任何操作
End If
Next cell
If surg Is Nothing Then Exit Sub
' 利用列偏移引用目标联合范围。
Dim ColumnOffset As Long:
ColumnOffset = ws.Columns(DST_INSERT_COLUMN).Column - scrg.Column
Dim durg As Range: Set durg = surg.Offset(, ColumnOffset)
' 插入。
Application.ScreenUpdating = False
durg.Insert Shift:=xlToRight
' 复制源联合行到目标联合行。
Dim sarg As Range
For Each sarg In surg.Areas
' 仅复制值（快速）。
sarg.Offset(, ColumnOffset).Value = sarg.Value
' 复制公式和格式（慢）。
'sarg.Copy sarg.Offset(, ColumnOffset)
Next sarg
' 清除源联合范围中的内容。
surg.ClearContents
Application.ScreenUpdating = True
' 通知。
MsgBox "MoveIt2已完成。", vbInformation
End Sub
英文:
Copy-Insert Row Ranges
<!-- language: lang-vb -->
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
通过集体智慧和协作来改善编程学习和解决问题的方式。致力于成为全球开发者共同参与的知识库，让每个人都能够通过互相帮助和分享经验来进步。
评论