تم عمل المطلوب وزيادة حبتين بحيث تتحدث القوائم المنسدلة مع كل تغيير في عدد الصفحات او اضافة اسماء جديدة في اي صفحة
ما عدا "go" و "tarheel"
CODE
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
الملف مرفق
احتاج كود ترحيل مبلغ الى عدد 7 شيتات
