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