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.
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
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
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.