Question

大家好，再次感谢您的帮助！

我正在尝试构建一个与两张纸之间的ID匹配的宏，然后找到该值并将标头从扫描的纸复制到另一张纸（我将附上屏幕截图，以更好地理解我的工作：-) ）

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

 ID   Month of No      Month of Maybe      Month of Yes

第2行：1月1日，2月3月

Row3：3月1日2月3日

基本上，它首先需要扫描列（或以任何其他方式）以查找值“否”，然后扫描值“ Maybe”，然后扫描值“是”，然后复制值首次出现时的标题。我试过只复制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

再次感谢您的所有帮助！

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，它检查“否”，“也许”和“是”，并且在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）。

根据条件将值从一张纸复制到另一张VBA的问题

1 个答案: