根据列中的文本将单元格值复制并粘贴到特定的单元格

Question

I have a Excel file, its look like...

After the macros, this will be the end results:

[

I want macro that read column "B", and paste first country from column "C" in the same cells of column "A", after he find duplicate cell in "B", he copy next country from column "C", and does the same as I wrote with first country and etc.

I found code from similar question and tried adapt it to my task:

Sub GetText2()
Dim CellValue As String
Dim RowCrnt As Integer
Dim RowMax As Integer

With Sheets("Sheet1")   
  RowMax = .Cells(Rows.Count, "B").End(xlUp).Row
  For RowCrnt = 2 To RowMax
    CellValue = .Cells(RowCrnt, 2).Value
    If CellValue <> "" Then
      .Cells(RowCrnt, 1).Value = Cells(RowCrnt, 5)
    Else
      .Cells(RowCrnt, 1).Value = .Cells(RowCrnt - 1, 5).Value
    End If
  Next
End With
End Sub

But it does not work as it should.

Can someone help me with these? Thanks.

Answer 1

I think this does what you want. Your code doesn't seem to do any checking of whether the column B value already exists.

Sub x()

Dim r1 As Long, r2 As Long

r1 = 2: r2 = 2

Do While Cells(r1, 2) <> vbNullString
    If IsNumeric(Application.Match(Cells(r1, 2), Range(Cells(1, 2), Cells(r1 - 1, 2)), 0)) Then
        r2 = r2 + 1
    End If
    Cells(r1, 1).Value = Cells(r2, 3).Value
    r1 = r1 + 1
Loop

End Sub

Answer 2

I think it will resolve your question.

Private Sub GetText2()
Dim CellValue As String
Dim RowCrnt As Integer
Dim RowMaxB As Integer
Dim RowMaxC As Integer
Dim RowMaxA As Integer
Dim wsh As Worksheet
Dim i As Integer
Dim checkDup As Integer


Set wsh = ThisWorkbook.Sheets("Sheet1")
'get max row of each Row
RowMaxB = wsh.Cells(Rows.Count, "B").End(xlUp).Row
RowMaxC = wsh.Cells(Rows.Count, "C").End(xlUp).Row
RowMaxA = wsh.Cells(Rows.Count, "A").End(xlUp).Row

If RowMaxA > 2 Then
'Clear contents of column A before write value. if > 2 to case Column A is blank
wsh.Range("A2:A" & RowMaxA).ClearContents
End If

'Run each row of column B
  For RowCrnt = 2 To RowMaxB
  checkDup = 0
    CellValue = wsh.Cells(RowCrnt, 2).Value
    If CellValue <> "" Then
         If RowCrnt = 2 Then
         'if check row is first row so set first value of column C to it
         checkDup = 0
         Else

             For i = RowCrnt - 1 To 2 Step -1
             ' loop backwards to find duplicate value in column B
                If wsh.Cells(i, 2).Value = CellValue And wsh.Cells(i, 1).Value <> "" Then
                ' if exist duplicate value so run function to find next value of column C
                wsh.Cells(RowCrnt, 1).Value = findInColC(wsh, wsh.Cells(i, 1).Value, RowMaxC, "C")
                checkDup = 1
                Exit For
                Else

                End If

            Next
         End If

        If checkDup = 0 Then
            wsh.Cells(RowCrnt, 1).Value = wsh.Cells(2, 3).Value
        Else
        End If

    Else
    End If
  Next

'release variables
 CellValue = ""
 RowCrnt = 0
 RowMaxB = 0
 RowMaxC = 0
 RowMaxA = 0
 Set wsh = Nothing
 i = 0
 checkDup = 0

End Sub
Function findInColC(wshSheet As Worksheet, stringFind As String, lastRow As Integer, FindColumn As String) As String
Dim i As Integer
For i = 2 To lastRow
If stringFind = wshSheet.Cells(i, FindColumn).Value Then
    If i = lastRow Then
    'if value find in A is last value in column C so set first value of Column C for it.
    findInColC = wshSheet.Cells(2, FindColumn).Value
    Else
    findInColC = wshSheet.Cells(i + 1, FindColumn).Value
    End If

Else
End If
Next

End Function