Struggling to understand why code isn't working (search/copy/paste with matched criteria)

[redspanna]

Hi all

I have managed to piece together the code below from various sources on the net (as my code writing skills are poor)

Sub Add_Training_Records2()
Application.ScreenUpdating = False
Dim i As Long
Dim wb As Workbook
Dim Lastrow As Long
Dim Lastrowa As Long

Dim rFndCell As Range
Dim strData As String
Dim stFnd As String
Dim Code As String
Dim fCol As Integer
Dim sh As Worksheet
Dim ws As Worksheet
Dim cell As Range

Set ws = Sheets("Data2")
Set sh = Sheets("Database2")
stFnd = Sheets("Data2").Range("A3").Value
    

For Each wb In Workbooks
If wb.Name Like "all*" Then
wb.Activate
Range("A1:L8000").Select
Selection.copy

Workbooks("Tracker").Sheets("Data2").Activate
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("D:E").Select
Application.CutCopyMode = False
Selection.NumberFormat = "[$-409]d-mmm-yy;@"
End If
Next


Sheets("Data2").Select
For Each cell In ActiveSheet.Range("A3:A30")
With sh
Set rFndCell = .Range("A:A").Find(stFnd, LookIn:=xlValues)
If Not rFndCell Is Nothing Then


If Sheets("Data2").Range("B3").Value Like "*Complaint*" Then
fCol = rFndCell.Row
Sheets("Data2").Range("E3").copy sh.Cells(fCol, 7)
Sheets("Data2").Select
Rows("3:3").Select
Selection.Delete Shift:=xlUp



ElseIf Sheets("Data2").Range("B3").Value Like "Aviation*" Then
fCol = rFndCell.Row
Sheets("Data2").Range("E3").copy sh.Cells(fCol, 12)
Sheets("Data2").Select
Rows("3:3").Select
Selection.Delete Shift:=xlUp


ElseIf Sheets("Data2").Range("B3").Value Like "Dangerous*" Then
fCol = rFndCell.Row
Sheets("Data2").Range("E3").copy sh.Cells(fCol, 17)
Sheets("Data2").Select
Rows("3:3").Select
Selection.Delete Shift:=xlUp


End If
Else
End If
End With
Next cell


End Sub

So here is what I want the code to do...

1) Go to another open workbook and copy selected data / paste this back into original workbook called Tracker - This part of code works fine
2) Look at cell value of A3 in sheet Data2, go to Database2 sheet and find same number value through column A
3) Once found (and there will always be a match) go back to Data2
4) Check the data string in cell B3 and depending on result carry out slightly different task

If B3 data string is likeComplaint (the string will always start with this word but others that follow are different eg Complaint Study , Complaint Group then
copy the value of cell E3 and paste this into the same row where the earlier number value was matched with an offset of 7 columns
so if originally the number value was found in cell A36 of Database2, then the value of cell E3 in Data2 will be pasted to G36

or

If B3 data string is likeAviation (the string will always start with this word but others that follow are different eg Aviation Study , Aviation Group then
copy the value of cell E3 and paste this into the same row where the earlier number value was matched with an offset of 12 columns
so if originally the number value was found in cell A36 of Database2, then the value of cell E3 in Data2 will be pasted to G36

or

If B3 data string is likeDangerous (the string will always start with this word but others that follow are different eg Dangerous Study , Dangerous Group then
copy the value of cell B3 and paste this into the same row where the earlier number value was matched with an offset of 17 columns
so if originally the number value was found in cell A36 of Database2, then the value of cell E3 in Data2 will be pasted to G36

5) once these actions are complete, return to Data2 sheet and delete whole of row 3, thus moving next row of data to be checked up to Row 3
6) Loop this sequence until there are no more values though column A in sheet Data2 to check.


The code above doesn't seem to be looping properly as a result is only placed into one matched cell when clearly there are many

Sorry for the long post but hope someone can look thru this as its driving me crazy and I'm sure there must be a simple explanation

Many thanks in advance , yours hopefully

 

[redspanna]

Just wanted to say thanks so much RCBricker for all your patience and suggestions, Finally got above to work, so again thank you

 

[RCBricker]

Glad I could help