excel - 根据条件将值从一张纸复制到另一张纸

Question

我正在尝试构建一个与两张纸之间的 ID 匹配的宏，然后找到该值并将标题从扫描的纸复制到另一张纸。

SheetOne 前几行的最终结果将是：

      ID 否月份 可能月份 是月份
第 2 行：1 月 1 日 2 月 3 月
第 3 行：1 月 2 日 3 月 4 月

它需要首先扫描列（或任何其他方式）以查找值“No”，然后查找值“Maybe”，然后查找值“Yes”，然后复制该值首次出现时的标题。我试图在 ID 匹配后复制任何值，但这没有用。

SheetOne 截图：

SheetTwo 截图：

我处于起步阶段。到目前为止，这是我的代码：

Sub movingValues()

'declaring/setting variables

Dim SheetOneWs As Worksheet
Dim SheetTwoWs As Worksheet

Dim SheetOneLastRow As Long
Dim SheetTwoLastRow As Long

Dim SheetOneRng As Range
Dim SheetTwoRng As Range

Set SheetOneWs = ThisWorkbook.Worksheets("SheetOne")
Set SheetTwoWs = ThisWorkbook.Worksheets("SheetTwo")

SheetOneLastRow = SheetOneWs.Range("A" & Rows.Count).End(xlUp).Row
SheetTwoLastRow = SheetTwoWs.Range("A" & Rows.Count).End(xlUp).Row

Set SheetOneRng = SheetOneWs.Range("A2:D13" & SheetOneLastRow)
Set SheetTwoRng = SheetTwoWs.Range("A2:M13" & SheetTwoLastRow)

'work process

For i = 2 To SheetOneLastRow

    If SheetOneWs.Range(i, 1).Value = SheetTwoWs.Range(i, 1).Value Then
        SheetTwoWs.Cells(i, 2).Copy
        SheetOneWs.Activate
        SheetOneWs.Cells(i, 2).Select
        ActiveSheet.Paste
        SheetTwoWs.Activate
    End If

Next i

End Sub

标签： excelvba

Answer 1

原始代码

这应该有效：

Sub movingValues()

    'declaring/setting variables

    Dim SheetOneWs As Worksheet, SheetTwoWs As Worksheet
    Dim SheetOneLastRow As Long, SheetTwoLastRow As Long
    Dim SheetOneRng As Range, SheetTwoRng As Range
    Dim cell As Range, i As Integer

    Application.Calculation = xlCalculationManual

    Set SheetOneWs = ThisWorkbook.Worksheets("SheetOne")
    Set SheetTwoWs = ThisWorkbook.Worksheets("SheetTwo")
    SheetOneLastRow = SheetOneWs.Range("A" & Rows.Count).End(xlUp).Row
    SheetTwoLastRow = SheetTwoWs.Range("A" & Rows.Count).End(xlUp).Row
    Set SheetOneRng = SheetOneWs.Range("A2:D13" & SheetOneLastRow)
    Set SheetTwoRng = SheetTwoWs.Range("A2:M13" & SheetTwoLastRow)

    SheetOneWs.Range("B2:D13").Value = ""

    For i = 2 To SheetTwoLastRow
        'For Each cell In SheetTwoWs.Range(Cells(i, "B"), Cells(i, "M"))
        For Each cell In SheetTwoWs.Range("B" & i & ":" & "M" & i)
            If cell.Value = "No" Then
                SheetOneWs.Cells(cell.Row, "B").Value = SheetTwoWs.Cells(1, cell.Column)
                Exit For
            End If
            SheetOneWs.Cells(cell.Row, "B").Value = "No data"
        Next cell
        For Each cell In SheetTwoWs.Range("B" & i & ":" & "M" & i)
            If cell.Value = "Maybe" Then
                SheetOneWs.Cells(cell.Row, "C").Value = SheetTwoWs.Cells(1, cell.Column)
                Exit For
            End If
            SheetOneWs.Cells(cell.Row, "C").Value = "No data"
        Next cell
        For Each cell In SheetTwoWs.Range("B" & i & ":" & "M" & i)
            If cell.Value = "Yes" Then
                SheetOneWs.Cells(cell.Row, "D").Value = SheetTwoWs.Cells(1, cell.Column)
                Exit For
            End If
            SheetOneWs.Cells(cell.Row, "D").Value = "No data"
        Next cell

    Next i


    Application.Calculation = xlCalculationManual
End Sub

我正在努力将代码缩减为单个 for 循环，因此我会尽快更新更好的代码，但上面的代码可以解决问题。

更新代码

我定义了第二个 Sub 来检查“No”、“Maybe”和“Yes”，并且这个 sub 在For循环中被调用了 3 次。

Option Explicit

    Dim SheetOneWs As Worksheet, SheetTwoWs As Worksheet

Sub movingValues()

    'declaring/setting variables
    Dim SheetOneLastRow As Long, SheetTwoLastRow As Long
    Dim SheetOneRng As Range, SheetTwoRng As Range
    Dim cell As Range, i As Integer
    Set SheetOneWs = ThisWorkbook.Worksheets("SheetOne")
    Set SheetTwoWs = ThisWorkbook.Worksheets("SheetTwo")
    Application.Calculation = xlCalculationManual

    SheetOneLastRow = SheetOneWs.Range("A" & Rows.Count).End(xlUp).Row
    SheetTwoLastRow = SheetTwoWs.Range("A" & Rows.Count).End(xlUp).Row
    Set SheetOneRng = SheetOneWs.Range("A2:D13" & SheetOneLastRow)
    Set SheetTwoRng = SheetTwoWs.Range("A2:M13" & SheetTwoLastRow)

    SheetOneWs.Range("B2:D13").Value = ""

    For i = 2 To SheetTwoLastRow
        'For Each cell In SheetTwoWs.Range(Cells(i, "B"), Cells(i, "M"))
        CheckValue "No", "B", i
        CheckValue "Maybe", "C", i
        CheckValue "Yes", "D", i
    Next i
    Application.Calculation = xlCalculationManual
End Sub

Sub CheckValue(checkString As String, colNum As String, i As Integer)
    Dim cell As Range
    For Each cell In SheetTwoWs.Range("B" & i & ":" & "M" & i)
        If cell.Value = checkString Then
            SheetOneWs.Cells(cell.Row, colNum).Value = SheetTwoWs.Cells(1, cell.Column)
            Exit For
        End If
        SheetOneWs.Cells(cell.Row, colNum).Value = "No data"
    Next cell

End Sub

您的某些变量 ( SheetOneRng) 不再需要。