VBA code need help as I'm stuck

VBA Need help trying to solve, Select data and records in next column the data below the found data od the selected
I have data in column C starting at row 20. I want to select one of the cells in column C;for data, for Example: 1-20-F. once selected I want to run macro that would search in column C for any data with the letter F, once it finds the data with the letter F it will tell me what is found below the data with the letter F. so if 3-15-H is found below the the data with the letter
F it would record it in the D column at the row 20 the letter H, this would continue until there are no more data found with the letter F. I would examine this data then I would start a new search by selecting another cell with data for example 8-46-P. please help as I am stuck! thank you!!!

Example

Could you attach an example spreadsheet? It is difficult to picture what you need without seeing an example.

Thanks,
-Max

Example

Column C. column D
1-12-E H
3-23-H P
1-13-G
3-17-E
5-42-P

I selected the 3-17-E

So I select data the cell in

So I select data the cell in column C the 3-17-E and macro looks in column C and returns the letter in which was found below any data containing letter E and returns what is found below that data containing letter E for example: H and P placed in column D.

This should work

Hi Corpsman000,

Give this code a shot (This assumes you have no column headers, it deletes all data in column D when you rerun the macro):

Sub corpsman000()
Dim SRow As Integer
Dim LRow As Integer
Dim DRow As Integer
Dim CLetter As String
Dim i As Integer

i = ActiveCell.Row
CLetter = Right(ActiveCell.Value, 1)

Columns(4).ClearContents

LRow = Cells(Rows.Count, 3).End(xlUp).Row
DRow = Cells(Cells(Rows.Count, 4).End(xlUp).Row, 4).Row

Do Until i = LRow
If Right(Cells(i, 3).Value, 1) = CLetter Then
Cells(DRow, 4) = Right(Cells(i + 1, 3).Value, 1)
DRow = DRow + 1
End If
i = i + 1
Loop
End Sub

ok it works, great! but lets

ok it works, great! but lets say i select data from near the bottom of column C, say 200 rows down, the macro currently only starts from that point down, not at the top where it should look through entire data starting at row 20 column C. and if possible place the results like it is in column D but instead of placed in row 1, place in row 20. please, Thank you

Try This

This should work:

Sub corpsman000()
Dim SRow As Integer
Dim LRow As Integer
Dim DRow As Integer
Dim CLetter As String
Dim i As Integer

i = 20
CLetter = Right(ActiveCell.Value, 1)

Columns(4).ClearContents

LRow = Cells(Rows.Count, 3).End(xlUp).Row
If DRow = Cells(Cells(Rows.Count, 4).End(xlUp).Row, 4).Row < 20 Then
DRow = 20
Else
DRow = Cells(Cells(Rows.Count, 4).End(xlUp).Row, 4).Row
End If

Do Until i = LRow
If Right(Cells(i, 3).Value, 1) = CLetter Then
Cells(DRow, 4) = Right(Cells(i + 1, 3).Value, 1)
DRow = DRow + 1
End If
i = i + 1
Loop
End Sub
 

 

__________________________________________________________________________________________________________________________

Here is an example with 3-17-E selected:

Before:

 

After:

 

 

 

 

Excellent Work! Thank you

Excellent Work! Thank you very much!

Hello Again

When I try and comment on yournew post, it says I am triggering the spam filter for some reason and wont let me post. So I will post the code here:

This code should do the trick:

Sub Corpsman0002()

Dim DRow2 As Integer
Dim Erow As Integer

Columns("E:F").Delete

If Cells(Rows.Count, 4).End(xlUp).Row < 20 Then
MsgBox "No Data Available"
Exit Sub
Else
DRow2 = Cells(Rows.Count, 4).End(xlUp).Row
End If

Range(Cells(20, 4), Cells(DRow2, 4)).Copy
Range(Cells(20, 5), Cells(DRow2, 5)).Select
Selection.PasteSpecial Paste:=xlPasteValues
If DRow2 > 20 Then ActiveSheet.Range(Cells(20, 5), Cells(DRow2, 5)).RemoveDuplicates Columns:=1, Header:=xlNo

Erow = Cells(Rows.Count, 5).End(xlUp).Row

Cells(20, 6) = "=Countif(" & Cells(20, 4).Address & ":" & Cells(DRow2, 4).Address & ",E20)"

Cells(20, 6).Select
If Len(Cells(21, 5)) > 0 Then Selection.AutoFill Destination:=Range(Cells(20, 6), Cells(Erow, 6))
Range(Cells(20, 6), Cells(Erow, 6)).Copy
Range(Cells(20, 6), Cells(Erow, 6)).Select
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Range("F20").Select

End Sub

 

But if you would like to add this to the preivous code I sent over in the other thred, use this:

Sub corpsman000()
Dim SRow As Integer
Dim LRow As Integer
Dim DRow As Integer
Dim CLetter As String
Dim i As Integer
Dim DRow2 As Integer
Dim Erow As Integer

i = 20
CLetter = Right(ActiveCell.Value, 1)

Columns("D:F").ClearContents

LRow = Cells(Rows.Count, 3).End(xlUp).Row
If DRow = Cells(Cells(Rows.Count, 4).End(xlUp).Row, 4).Row < 20 Then
DRow = 20
Else
DRow = Cells(Cells(Rows.Count, 4).End(xlUp).Row, 4).Row
End If

Do Until i = LRow
If Right(Cells(i, 3).Value, 1) = CLetter Then
Cells(DRow, 4) = Right(Cells(i + 1, 3).Value, 1)
DRow = DRow + 1
End If
i = i + 1
Loop

If Cells(Rows.Count, 4).End(xlUp).Row < 20 Then
MsgBox "No Data Available"
Exit Sub
Else
DRow2 = Cells(Rows.Count, 4).End(xlUp).Row
End If

Range(Cells(20, 4), Cells(DRow2, 4)).Copy
Range(Cells(20, 5), Cells(DRow2, 5)).Select
Selection.PasteSpecial Paste:=xlPasteValues
If DRow2 > 20 Then ActiveSheet.Range(Cells(20, 5), Cells(DRow2, 5)).RemoveDuplicates Columns:=1, Header:=xlNo

Erow = Cells(Rows.Count, 5).End(xlUp).Row

Cells(20, 6) = "=Countif(" & Cells(20, 4).Address & ":" & Cells(DRow2, 4).Address & ",E20)"

Cells(20, 6).Select
If Len(Cells(21, 5)) > 0 Then Selection.AutoFill Destination:=Range(Cells(20, 6), Cells(Erow, 6))
Range(Cells(20, 6), Cells(Erow, 6)).Copy
Range(Cells(20, 6), Cells(Erow, 6)).Select
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Range("F20").Select

End Sub

 

Let me know if this doesn't work!

Sincerely,

-Max

 

how do i get you a copy of

how do i get you a copy of example i am fairly new to sight

Which question are you

Which question are you looking for example