根据条件将值从一张纸复制到另一张纸 [英] Copying values based on condition from one sheet to another

问题描述

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

I am trying to build a macro that will match the ID between two sheets, then find the value and copy the header from scanned sheet to another.

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

The end result for SheetOne first couple of rows would be:

      ID   Month of No      Month of Maybe      Month of Yes
Row2: 1     January          February            March
Row3: 2     January          March               April

它首先需要扫描列(或以其他方式)，以查找值否"，然后扫描值"Maybe"，然后扫描值是"，然后复制该值首次出现时的标题.一旦ID匹配，我就尝试只复制任何值，但这没用.

It needs to scan through columns (or any other way) at first for value "No", then for value "Maybe", then for value "Yes" and then copy the header of when the value first appeared. I've tried to just copy any value once ID's match, but that didn't work.

SheetOne的屏幕截图:

Screenshot of SheetOne:

SheetTwo的屏幕截图:

Screenshot of SheetTwo:

我正处于起步阶段.到目前为止，这是我的代码:

I am in the beginning phase. This is my code so far:

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

推荐答案

原始代码

这应该有效:

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循环，因此我将尽快使用更好的代码进行更新，但是上面的代码可以解决问题.

I am working on cutting down the code into a single for loop so I'll update soon with better code, but the above code does the trick.

更新后的代码

我定义了第二个Sub，它检查否"，也许"和是"，并且在 For 循环中，该子被调用了3次.

I define a second Sub which checks the "No"s, "Maybe"s and "Yes"s, and this sub is called 3 times in the For loop.

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 ).

Some of your variables (SheetOneRng) are no longer required.

这篇关于根据条件将值从一张纸复制到另一张纸的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！