كود ترحيل بقائمتين منسدلتين

Sub Test()

    Dim x, ws As Worksheet, sh As Worksheet, sName As String, lr As Long, r As Long, m As Long

    Application.ScreenUpdating = False

        Set ws = ThisWorkbook.Worksheets(1)

        lr = ws.Cells(25, 1).End(xlUp).Row

        For r = 3 To lr

            sName = CStr(ws.Cells(r, 5).Value)

            If Evaluate("ISREF('" & sName & "'!A1)") Then

                Set sh = ThisWorkbook.Worksheets(sName)

                m = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1

                x = Application.Match(ws.Range("G2").Value, sh.Rows(1), 0)

                If Not IsError(x) Then

                    sh.Cells(m, 1).Resize(1, 4).Value = ws.Cells(r, 1).Resize(1, 4).Value

                    sh.Cells(m, x).Value = ws.Cells(r, 6).Value

                End If

            End If

        Next r

    Application.ScreenUpdating = True

    MsgBox "Done...", 64, "YasserKhalil Excel-Egy"

End Sub

Option Explicit

Dim Targ      As Worksheet

Dim Source      As Worksheet

Dim lr          As Long

Dim AR_Sh()

Dim I%, M%, Col%, X%

'+++++++++++++++++++++++

Private Sub Worksheet_Activate()

dataval

End Sub

'++++++++++++++++++++++++++++



Private Sub Worksheet_Change(ByVal Target As Range)

 Application.EnableEvents = False

 If (Target.Address = "$E$2" Or Target.Address = "$G$2") And _

 Target.Count = 1 Then

 CoypFilteredData

 End If

  Application.EnableEvents = True

End Sub

'++++++++++++++++++++++++++++++++++





Sub dataval()

M = 1

Set Targ = Sheets("ترحيل واستدعاء")

For I = 1 To Sheets.Count

If Sheets(I).Name Like "#*" Then

 ReDim Preserve AR_Sh(1 To M)

  AR_Sh(M) = Sheets(I).Name

  M = M + 1

  End If

  Next

With Targ.Cells(2, 5).Validation

.Delete

.Add 3, Formula1:=Join(AR_Sh, ",")

End With

End Sub

Sub CoypFilteredData()

Dim FLt_sh As Worksheet

M = 4

Set Targ = Sheets("ترحيل واستدعاء")

X = Targ.Range("A25").End(3).Row

If X < 4 Then X = 4

 Targ.Range("A4:G" & X).ClearContents

 If Targ.Range("E2") = vbNullString Or _

    Targ.Range("G2") = vbNullString Then Exit Sub



Set FLt_sh = Sheets(CStr(Targ.Cells(2, 5)))

 

 lr = FLt_sh.Cells(Rows.Count, "A").End(xlUp).Row

 

 Col = FLt_sh.Range("E1:N1"). _

 Find(Targ.Cells(2, "G"), lookat:=1).Column

 

 Targ.Cells(M, 1).Resize(lr - 1, 4).Value = _

 FLt_sh.Cells(2, 1).Resize(lr - 1, 4).Value

 

 Targ.Cells(M, "E").Resize(lr - 1).Value = _

 FLt_sh.Name

 

 Targ.Cells(M, "G").Resize(lr - 1).Value = _

  FLt_sh.Cells(2, Col).Resize(lr - 1).Value

  

  Targ.Cells(M, "F").Resize(lr - 1).Value = _

 FLt_sh.Cells(2, "O").Resize(lr - 1).Value

End Sub