VBA / Excel – 查找数字和移动范围

在我身上轻松 – 全新的VBA。 我很难完成这个简单的过程，我的大脑经过search和search后， 我正在处理近5万行数据。 我需要…

1. 检查C列，看它是否包含数字。
2. 如果不行 – 什么也不做。
3. 如果它包含数字 – 从相邻行（D列）剪切数据。

4. 将其粘贴到A列

   Sub MoveRange() If IsEmpty(Range("C2:C40001").Value) = False Then Range("D2:D40001").Select Selection.Cut Range("A2").Select ActiveSheet.Paste End If End Sub

我已经能够手写剪切和粘贴部分 – 工作正常。 我必须在“IsEmpty”部分丢失一些东西。 列C中的单元格为空或包含数字 – 没有混合字符。 我认为有些事情我没有正确设置，标记数字？

现在代码运行，但它将所有数据从列D移动到列A.

任何帮助都将不胜感激。

Answer 1

数组解决scheme，即使它有一个循环，对于大型数据集可能也是最有效的：

编辑更新后的代码执行“剪切”结果而不是“复制”结果，并将结果放在同一行中。

 Sub tgr_Array() Dim ws As Worksheet Dim aData As Variant Dim aResults As Variant Dim i As Long, j As Long Set ws = ActiveWorkbook.ActiveSheet 'Change to actual sheet if necessary ws.Range("A2:A" & ws.Rows.Count).Clear 'Clear previous results, if any With ws.Range("C2", ws.Cells(ws.Rows.Count, "C").End(xlUp)) If .Row < 2 Then Exit Sub 'No data ReDim aResults(1 To .Rows.Count, 1 To 1) aData = .Resize(, 2).Value End With For i = LBound(aData, 1) To UBound(aData, 1) If IsNumeric(aData(i, 1)) And Len(Trim(aData(i, 1))) > 0 Then aResults(i, 1) = aData(i, 2) aData(i, 2) = vbNullString End If Next i ws.Range("A2").Resize(UBound(aResults, 1)).Value = aResults ws.Range("C2").Resize(UBound(aData, 1), UBound(aData, 2)).Value = aData End Sub 

Answer 2

您可以使用循环或filter来获取没有空白单元格

 Sub MoveRangeUsingAloop() Dim rng As Range, LstRw As Long, c As Range LstRw = Cells(Rows.Count, "C").End(xlUp).Row Set rng = Range("C2:C" & LstRw).SpecialCells(xlCellTypeConstants, 1) Application.ScreenUpdating = 0 For Each c In rng Cells(Rows.Count, "A").End(xlUp).Offset(1) = c.Offset(, 1) Next c End Sub Sub UsingFilter() Dim rng As Range, LstRw As Long LstRw = Cells(Rows.Count, "C").End(xlUp).Row Set rng = Range("C2:C" & LstRw).SpecialCells(xlCellTypeConstants, 1) Application.ScreenUpdating = 0 Columns("C:C").AutoFilter Field:=1, Criteria1:="<>" Set rng = Range("D2:D" & LstRw).SpecialCells(xlCellTypeVisible) rng.Copy Range("A2") ActiveSheet.AutoFilterMode = 0 End Sub