Question

轻松对待我 - VBA全新。我无法完成这个简单的过程，我的大脑在搜索和搜索后被扰乱了。我正在使用近50,000行数据。我需要......

检查C列以查看它是否包含数字。
如果没有 - 什么也不做。
如果确实包含数字 - 从相邻行（D列）剪切数据。
将其粘贴到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

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

编辑更新了执行＆＃34; cut＆＃34;的代码结果而不是＆＃34; copy＆＃34;结果并将结果放在同一行中。

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

您可以使用循环或过滤器来获取无空白单元格

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

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

2 个答案: