Matching Values in Two Sheets for Databasing

Hi all,

Another question I'm hoping to get answered by the community!

My need (see attached file to work with):
1. Check each cell value in sheet LWDB column A to the column A in sheet MyDB
2. If found take that cell values entire row of data (LWDB sheet), insert data row below found value (MyDB sheet) and offset one column (being data to start in column B)
3. If cell value in LWDB not found, add that value to list (with formatting in MyDB) to MyDB then add the LWDB row below it
4. Continue through loop to all items have been addressed.


My code:

Sub Databasing()
'
' Databasing Macro
'
'
    Dim c As Range, d As Range
    Worksheets("LWDB").Activate
    For Each c In Range("A2:A15")
        For Each d In Worksheets("MyDB").Range("A2:A30")
            If c = d Then
                c.EntireRow.Copy
                d.Offset(1, 0).Insert Shift:=xlShiftUp, CopyOrigin:=True
            End If
        Next
    Next
        
End Sub

My thoughts: I have had my code work for points 1 & 2 on sample of 5, however the matching code crashes due to processing past this amount! Would it be better to use some sort of Array or any other thoughts on cutting this down as the databasing could be up to 400 entries.

Appreciate the help

Some of the cells have duplicates values, so the return would also be 2,3 or 4 times.

Sub copyfrom()

    Dim c3 As Range, c4 As Range, LR2 As String, ms As Worksheet, LR1&
    
    Application.ScreenUpdating = 0
    Application.EnableEvents = 0
    Set ms = Sheets("MyDB")
    
With Sheets("LWDB")

    LR1 = ms.Cells(Rows.Count, 1).End(xlUp).Row
    LR2 = Worksheets("LWDB").Cells(Rows.Count, 1).End(xlUp).Row
    
    For Each c4 In .Range("A2:A" & LR2)
    
        Set c3 = ms.Range("A2:A" & Rows.Count).Find(c4, , xlValues, xlWhole)
    
        If Not c3 Is Nothing Then
             c3.Offset(1, 1).EntireRow.Insert
             c4.Resize(, 7).Copy
             ms.Cells(c3.Row + 1, 2).PasteSpecial xlValues
        Else
            c4.Resize(, 7).Copy
            ms.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
        End If
    Next
End With
Application.ScreenUpdating = True
Application.EnableEvents = True

Set ms = Nothing
End Sub

AB33 - this code is perfect, worked through the data with no duplicates and in the position in under a second! Many thanks