Sub Find_and_Move()
    Dim arrListNames() As String, i%, j%, k%, wshI As Worksheet, arrIn, arrOut
    
    For Each wshI In ActiveWorkbook.Worksheets
        If Not wshI.Name = "Общая_таблица" Then
            ReDim Preserve arrListNames(i)
            arrListNames(i) = wshI.Name
            i = i + 1
        End If
    Next
    For i = 0 To UBound(arrListNames, 1)
        With Worksheets("Общая_таблица")
            If Not .UsedRange.Find(arrListNames(i)) Is Nothing Then
                arrIn = .UsedRange.Find(arrListNames(i)).CurrentRegion
                ReDim arrOut(1 To UBound(arrIn, 1), 1 To UBound(arrIn, 2))
                    For j = 1 To UBound(arrIn, 1)
                        If arrIn(j, 1) <> "" Then
                            k = k + 1
                            arrOut(k, 1) = arrIn(j, 1): arrOut(k, 2) = arrIn(j, 2): arrOut(k, 3) = arrIn(j, 4)
                        End If
                    Next j
                With Worksheets(arrListNames(i))
                    .Range("a1").CurrentRegion.Offset(1, 0).ClearContents
                    .Range("A2").Resize(k, 3) = arrOut
                End With
                Erase arrIn: Erase arrOut: k = 0
            End If
        End With
    Next i
End Sub