احتاج كود ترحيل مبلغ الى عدد 7 شيتات

=IFERROR(LOOKUP(1,0/(tarheel!$C$2:$C$200=$C$1)/(tarheel!$B$2:$B$200=E$2),tarheel!$A$2:$A$200),"")

Option Explicit

Dim T As Worksheet

Dim Act_sh As Worksheet

Dim Sh As Worksheet

Dim Lt#, X#, y#, m#, Ro#

Dim Rg As Range, Where As Range

Dim D_name As Object

Dim ar(), itm

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

Sub fil_data_val()

Set T = Sheets("tarheel")



Lt = T.Cells(Rows.Count, 1).End(3).Row

Set D_name = CreateObject("Scripting.Dictionary")

For Each Sh In Sheets

    If Sh.Name = "tarheel" Or Sh.Name = "go" Then

    Else

        ReDim Preserve ar(m)

        ar(m) = Sh.Name

        m = m + 1

    End If

Next

    With T.Range("C2:C" & Lt).Validation

    .Delete

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

    End With

 For Each itm In ar

  m = Sheets(itm).Cells(2, Columns.Count).End(1).Column

   For X = 3 To m

   If Sheets(itm).Cells(2, X) <> vbNullString Then

    D_name(Sheets(itm).Cells(2, X).Value) = vbNullString

   End If

   Next X

 Next itm

 

 With T.Range("B2:B" & Lt).Validation

 .Delete

 .Add 3, Formula1:=Join(D_name.keys, ",")

 End With

 

 Erase ar: Set D_name = Nothing

End Sub

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

Sub fil_data()

Set T = Sheets("tarheel")

Lt = T.Cells(Rows.Count, 1).End(3).Row

 For m = 2 To Lt

  If T.Range("B" & m) <> "" Then

  Set Act_sh = Sheets(T.Range("C" & m) & "")

  Set Where = Act_sh.Range("D2:AA2")

  Set Rg = Where.Find(T.Range("B" & m), lookat:=1)

   If Not Rg Is Nothing Then

    y = Rg.Column

    Ro = Act_sh.Cells(Rows.Count, y).End(3).Row + 1

    Act_sh.Cells(Ro, y) = T.Range("A" & m)

   End If

   End If

   If Act_sh.Cells(Ro, 1) = vbNullString Then

    Act_sh.Cells(Ro, 1) = Format(Date, "d - m - yyyy")

    Act_sh.Columns(1).AutoFit

   End If

 Next m

   

End Sub

  m = Sheets(itm).Cells(2, Columns.Count).End(1).Column