Copying values based on condition from one sheet to another

Question

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.

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

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.

Screenshot of SheetOne:

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

Can you give an example of expected results? Would it be Jan, Feb, March for ID 1 and Jan, March, April for ID 2? — SJR
Hiya, sure thing. This is the screenshot of what the end result would look like: imgur.com/603BFk8 — Sergej Dikun
true, but this is part of much bigger macro and I can't use formulas there :-) — Sergej Dikun

PuravTheGreat PuravTheGreat · Accepted Answer · 2019-12-06T00:47:26

ORIGINAL CODE

This should work:

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

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.

UPDATED CODE

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

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

Copying values based on condition from one sheet to another

1 Answers