ترحيل واستدعاء بيانات فاتورةوقائمة منسدلة ديناميكية

[Mohamed.elahmer]

السادة الافاضل 

انا حاولت اعمل الاتى 

مطلوب عمل قائمة منسدلة ديناميكية  لنوع الصنف .

مطلوب عمل قائمة منسدلة ديناميكية بأسم الصنف مرتبطة بنوع الصنف .

المطلوب عند الضغط على زر الترحيل يتم ترحيل بيانات الفاتورة الى شيت البيع .

مطلوب سيريل لرقم الفاتورة يتم تغيرة اتوماتيك بعد الترحيل . ومش عارف برجاء المساعدة .... تــــم تعديل رفع الملف بإمتداد XLSM طالما انك تريد الترحيل بالأكواد

555555555555555.xlsm

[سليم حاصبيا]

هذا الكود مبدئياُ من أجل القوائم المنسدلة (المترابطة)

اذا لم تظهر  القائمة الرئيسية في النطاق من  B7 الى B31  من الصفحة (FATURA) غادر الضفجة ثم عد اليها من جديد

Option Explicit
Dim D As Worksheet, S As Worksheet
Dim F As Worksheet
Dim LrD%, LrS%, lrF%
'+++++++++++++++++++++++++++++++++
Private Sub Worksheet_Activate()
 data_val
End Sub
'++++++++++++++++++++++++++++++++++++

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim K%, t%, F_rg As Range
  Dim sec_arr(), mm%, y%
   Dim BoL As Boolean
  Dim Dt As Worksheet
  Set Dt = Sheets("DATA")
 Application.EnableEvents = False

If Not Intersect(Target, Range("B7:B31")) Is Nothing And _
  Target.Count = 1 Then
    If Target <> "" Then
     Set F_rg = Dt.Range("D1:K1").Find(Target, lookat:=1)
     If F_rg Is Nothing Then GoTo Fin
       BoL = True
     t = F_rg.Column
     mm = 2
      Do Until Dt.Cells(mm, t) = ""
          ReDim Preserve sec_arr(1 To mm - 1)
          sec_arr(mm - 1) = Dt.Cells(mm, t)
           mm = mm + 1
     Loop
   
  End If
 
     If BoL And mm > 2 Then
      With Target.Offset(, 1).Validation
       .Delete
       .Add 3, Formula1:=Join(sec_arr, ",")
      End With
      y = Application.RandBetween(1, mm - 2)
      Target.Offset(, 1) = sec_arr(y)
    End If
End If
Fin:
Application.EnableEvents = True
End Sub
'+++++++++++++++++++++++++++++++++++++

Sub Begin()
Set D = Sheets("Data")
Set S = Sheets("SALES")
Set F = Sheets("FATURA")
LrS = S.Cells(Rows.Count, 1).End(3).Row
lrF = F.Cells(Rows.Count, 2).End(3).Row

End Sub
'++++++++++++++++++++++++++++++++++++++++
Sub data_val()
Begin
 Dim ro%, i%, arr()
 ro = D.Cells(Rows.Count, 1).End(3).Row
 ReDim arr(1 To ro - 1)
  i = 2
  Do Until i = ro + 1
   arr(i - 1) = D.Cells(i, 1)
    i = i + 1
  Loop
 With F.Range("B7").Resize(25).Validation
 .Delete
 .Add 3, Formula1:=Join(arr, ",")
 End With
End Sub

الملف مرفق

My_Bok.xlsm

[Mohamed.elahmer]

جزاك الله خير  

الف مليون شكرا عى المجهود 

اتمنى استكمال زر الترحيل ورقم الفاتورة 

وشكرا مرة اخرى