Question

我有一个工作宏，它基本上从基础表中删除行，如果行中的值第一个单元格（列A）匹配目标工作表单元格中的值= B1，并将其粘贴到目标工作表中第一个空行（检查单元格）在A列中。但由于我的Excel功能需要略微改变，我需要做一些调整，但到目前为止我的所有尝试都失败了。

以下是工作代码：

Sub RowCopy()

Application.ScreenUpdating = False

Set shtarget = Sheets("TargetSheet")

Set shBase = Sheets("BaseSheet")

For i = shBase.Range("A" & shBase.Rows.Count).End(xlUp).Row To 1 Step -1
    If shBase.Cells(i, 1).Value = shtarget.Cells(1, 2).Value Then
    shBase.Rows(i).EntireRow.Cut
    shtarget.Rows(shtarget.Cells(shtarget.Rows.Count, 1).End(xlUp).Row + 1).EntireRow.Insert Shift:=xlDown
    shBase.Rows(i).EntireRow.Delete

End If

Next i

Application.CutCopyMode = False

Set shtarget = Nothing
Set shBase = Nothing

Application.ScreenUpdating = True

End Sub

以下是我正在处理的问题：

问题nr.1：

如果单元格B1包含混合文本和数字以及（短划线/逗号/空格），则代码不起作用，例如：“white - 32”。我曾尝试使用Variant，但每次都无法正常工作，并且数据排序速度相当慢，尤其是数据量较大时。

这里我试图用StrComp比较两个单元格，代码本身没有显示任何错误，但也没有做它应该做的事情 - 即 - 将数据复制到目标工作表：

Sub RowCopy()

Application.ScreenUpdating = False

Set shtarget = Sheets("TargetSheet")

Set shBase = Sheets("BaseSheet")

For i = shBase.Range("A" & shBase.Rows.Count).End(xlUp).Row To 1 Step -1
    If StrComp(shBase.Cells(i, 1).Value, shtarget.Cells(1, 2).Value) = 0 Then
    shBase.Rows(i).EntireRow.Cut
    shtarget.Rows(shtarget.Cells(shtarget.Rows.Count, 1).End(xlUp).Row + 1).EntireRow.Insert Shift:=xlDown
    shBase.Rows(i).EntireRow.Delete

End If

Next i

Application.CutCopyMode = False

Set shtarget = Nothing
Set shBase = Nothing

Application.ScreenUpdating = True

End Sub

我缺少什么？
是否有更有效的方法来比较单元格中的混合类型数据？

问题nr.2：

使用现有代码，复制整行会干扰页面右侧部分的目标工作表中的数据，因为它会向下移动行。但是，有必要从基础片材中剪切/复制行的某些部分（例如：来自A2：J2），并仅将目标片材区域中的数据从A粘贴到J，而不会弄乱目标片材的其他部分。它应该更像是踩1行，而不是插入和移动行，这与现有代码一起发生我尝试用Range（A2：J2）代替“EntireRow”，但它只留下了必要的数据丢失和错误的数据复制到我的目标表。

如何在下面的代码中定义一行的特定范围，仅粘贴目标表中的数据，而不插入新行（而不是弄乱目标表A：J范围之外的其他数据）？

Sub RowCopy()

Application.ScreenUpdating = False

Set shtarget = Sheets("TargetSheet")

Set shBase = Sheets("BaseSheet")

For i = shBase.Range("A" & shBase.Rows.Count).End(xlUp).Row To 1 Step -1
    If shBase.Cells(i, 1).Value = shtarget.Cells(1, 2).Value Then
    shBase.Rows(i).EntireRow.Cut
    shtarget.Rows(shtarget.Cells(shtarget.Rows.Count, 1).End(xlUp).Row + 1).EntireRow.Insert Shift:=xlDown
    shBase.Rows(i).EntireRow.Delete

End If

Next i

Application.CutCopyMode = False

Set shtarget = Nothing
Set shBase = Nothing

Application.ScreenUpdating = True

End Sub

Answer 1

我没有看到任何搜索问题（例如）＆＃34; white - 32＆＃34; ...

Sub RowCopy()

    Dim shtarget As Worksheet, shBase As Worksheet
    Dim vGet, cDest As Range, i As Long

    Application.ScreenUpdating = False

    Set shtarget = Sheets("TargetSheet")
    Set shBase = Sheets("BaseSheet")

    'get initial paste position
    Set cDest = shtarget.Cells(shtarget.Rows.Count, 1).End(xlUp).Offset(1, 0)
    'value being searched for
    vGet = shtarget.Cells(1, 2).Value

    For i = shBase.Range("A" & shBase.Rows.Count).End(xlUp).Row To 1 Step -1

        If shBase.Cells(i, 1).Value = vGet Then
            shBase.Cells(i, 1).Resize(1, 10).Copy cDest 'copy 10 columns
            shBase.Rows(i).EntireRow.Delete
            Set cDest = cDest.Offset(1, 0)
        End If

    Next i

    Application.CutCopyMode = False
    Application.ScreenUpdating = True

End Sub

从一个工作表到另一个工作表的部分行复制以及比较

1 个答案: