محمد هشام.

يوليو 2, 2024

وعليكم السلام ورحمة الله تعالى وبركاته

استبدل

=Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9+Feuil14!O9+Feuil14!R9+Feuil14!U9+Feuil14!X9+Feuil14!AA9+Feuil14!AD9+Feuil14!AG9+Feuil14!AJ9

بالمعادلة التالية

=IF($B$6=1;Feuil14!C9;IF($B$6=2;SUM(Feuil14!C9+Feuil14!F9);IF($B$6=3;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9);IF($B$6=4;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9);IF($B$6=5;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9+Feuil14!O9);IF($B$6=6;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9+Feuil14!O9+Feuil14!R9);IF($B$6=7;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9+Feuil14!O9+Feuil14!R9+Feuil14!U9);IF($B$6=8;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9+Feuil14!O9+Feuil14!R9+Feuil14!U9+Feuil14!X9);IF($B$6=9;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9+Feuil14!O9+Feuil14!R9+Feuil14!U9+Feuil14!X9+Feuil14!AA9);IF($B$6=10;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9+Feuil14!O9+Feuil14!R9+Feuil14!U9+Feuil14!X9+Feuil14!AA9+Feuil14!AD9);IF($B$6=11;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9+Feuil14!O9+Feuil14!R9+Feuil14!U9+Feuil14!X9+Feuil14!AA9+Feuil14!AD9+Feuil14!AG9);IF($B$6=12;SUM(Feuil14!C9+Feuil14!F9+Feuil14!I9+Feuil14!L9+Feuil14!O9+Feuil14!R9+Feuil14!U9+Feuil14!X9+Feuil14!AA9+Feuil14!AD9+Feuil14!AG9+Feuil14!AJ9)))))))))))))

و

=IF(Feuil1!$B$6>="1";SUMIFS(Feuil5!$E$11:$E$727;Feuil5!$B$11:$B$727;B9;Feuil5!$D$11:$D$727;$C$7);0)

قم باستبدالها ب

=SUMIFS(Feuil5!$E$10:$E$1000;Feuil5!$B$10:$B$1000;B9;Feuil5!$D$10:$D$1000;$C$7)

جلب البيانات حسب 2 الشهر.rar

يوليو 1, 2024

Sub RemoveChars()
Dim lr&, Cel As Range, A As String, r As Range
lr = Cells(Rows.Count, "b").End(xlUp).Row
Application.ScreenUpdating = False
Set r = Range("b2:b" & lr)
  For Each Cel In r
    A = Replace(Cel.Value, ",", " ")
    Cel.Value = A
  Next Cel
  Application.ScreenUpdating = True
End Sub

يوليو 1, 2024

المفروض انك تعلم ما يفعله الكود هو في الاصل لا يقوم بالتفريغ وانما يقوم بنسخ بيانات الاسم الموجود في الخلية F1

وبما ان الاسم مكرر اكثر من مرة مع وجود فراغات في الاعمدة المقابلة يقوم بنسخ لك قيمة فارغة لان تركيبة الكود هي جلب جميع بيانات الاسم حاول وضع تواريخ امام اسم محمد مثلا

وتجربة الكود لتتضح لديك الفكرة

6.PNG.30813948312de78cd63856b2e18705ac.PNG

بعد تنفيد الكود

7.PNG.01cf0be4ae4042ab7c94b5bb234d03f3.PNG

يوليو 1, 2024

ضع الكود التالي في حدث ورقة DATA لجلب اسماء العملاء

Private Sub Worksheet_Change(ByVal Target As Range)

 Set F = Sheets("DATA"): Set n = F.[G2]
 
 With Application
    .ScreenUpdating = False
  .EnableEvents = False
   
If Target.Column = 1 Then
F.Range("G2:G" & F.UsedRange.Rows.Count).ClearContents
  Set d = CreateObject("Scripting.Dictionary")
  a = Range(F.[A2], F.[A65000].End(xlUp)).Value
  For Each c In a
     d(c) = ""
  Next c
n.Resize(d.Count, 1) = Application.Transpose(d.keys)
   n.Resize(d.Count, 1).Sort Key1:=n, Order1:=xlAscending
      Set d = Nothing
  End If
  
  .EnableEvents = True
    .ScreenUpdating = True
  End With
End Sub

مع تسمية النطاق وليكن مثلا list

66.PNG.9bfe59f395cbe7417ff6d220b0ba77fe.PNG

واخيرا قم بنسخ هدا في حدث ورقة 7

Option Compare Text
Dim F(), OneRng, lr&
Public Property Get Sh2() As Worksheet: Set Sh2 = Worksheets("DATA")
End Property
Private Sub ComboBox1_Change()
Dim Cnt()
Set OneRng = ActiveCell: Cnt = Application.Transpose([List])
Me.ComboBox1.List = Cnt
If Me.ComboBox1.ListIndex = -1 And _
                    IsError(Application.Match(Me.ComboBox1, Cnt, 0)) Then
   Me.ComboBox1.List = Filter(Cnt, Me.ComboBox1.Text, True, vbTextCompare)
   Me.ComboBox1.DropDown
End If
  OneRng.Value = Me.ComboBox1
End Sub
'*************************
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim sh1 As Worksheet: Set sh1 = Worksheets("7")
lr = 150 'sh1.Range("a" & sh1.Rows.Count).End(xlUp).Row
 Set tmp = Range("C4:C" & lr)
   If Not Intersect(tmp, Target) Is Nothing And Target.Count = 1 Then
      If Cnt <> "" Then If IsError(Application.Match(Range(Cnt), F, 0)) Then Range(Cnt) = ""
F = Application.Transpose(Sh2.Range("list"))
 Me.ComboBox1.Height = Target.Height + 4
 Me.ComboBox1.Width = Target.Width
  Me.ComboBox1.BackColor = RGB(204, 253, 253)
    Me.ComboBox1.Top = Target.Top: Me.ComboBox1.Left = Target.Left: Me.ComboBox1 = Target
    Me.ComboBox1.Visible = True
    Me.ComboBox1.Activate
    Cnt = Target.Address
  Else
    Me.ComboBox1.Visible = False
  End If
End Sub
'*************************
Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  Set OneRng = ActiveCell
  If KeyCode = 13 Then
    If IsError(Application.Match(OneRng, F, 0)) Then OneRng = ""
    OneRng.Offset(1).Select
  End If
End Sub
'*************************
Private Sub ComboBox1_DropButtonClick()
lr = Sh2.Cells(Rows.Count, 7).End(xlUp).Row
ComboBox1.List = Sh2.Range("G2:G" & lr).Value
End Sub
'*************************
Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
  If Not iGblInhibitTextBoxEvents Then
  ComboBox1.Value = ""
  End If
End Sub

البحث باي جزء من الاسم

Capture.PNG.8766509fedb626a384a5ed242bed2db2.PNG

يمكنك استخدام نفس الكود على اي ورقة بعد تعديل الاسم

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim sh1 As Worksheet: Set sh1 = Worksheets("7") <======

قائمة بحث بجزء من الاسم.xlsb

يونيو 30, 2024

وعليكم السلام ورحمة الله تعالى وبركاته

هل هناك مانع لاستخدام الأكواد؟

يونيو 30, 2024

ما الغرض من فك حماية جميع اوراق العمل لتقوم بافراغ الخلايا المحددة على ورقة عمل واحدة

جرب هدا

Sub Protect()
Dim x As Worksheet
Set x = ActiveSheet
Application.ScreenUpdating = False
x.Unprotect "bac20022002"
With Selection
   .ClearContents
End With
 x.Protect "bac20022002"
Application.ScreenUpdating = True
End Sub

يونيو 30, 2024

اخي الكريم اظن ان الفكرة لم تتضح اليك لابد من وجود قاعدة بيانات يتم تعبئة عناصر الكومبوبوكس منها بحيث عند اختيارك للقيم المطلوبة تقوم بترحيلها للخلايا الهدف

لان طريقة اشتغالك على الملف بخلايا فارغة مع شرط تتابع وترابط القوائم تتطلب طريقة خاصة انت لم تكلف نفسك حتى لتصميم نمودج يوزرفورم للاشتغال عليه

بالتوفيق

يونيو 29, 2024

ربما لم تنتبه للمشاركة السابقة

في 28‏/6‏/2024 at 12:13, محمد هشام. said:

دا لم يكن عندك مانع لاستخدامها يكفي انشاء يوزرفورم صغير على الملف يتضمن 5 Combobox وزر وسوف احاول كتابة الاكواد الخاصة بدالك للتجربة

زيادة ان الملف المرفق مغاير عن الملف الاول هل تقصد قاعدة البيانات هي الاعمدة الملونة بالاحمر

لنفترض اننا قمنا بتحديد العناصر المختارة على عدد معين من الكومبوبوكس اين سيتم ترحيلها

يونيو 29, 2024

بطريقة اخرى

Option Compare Text
Public Property Get F() As Worksheet: Set F = Worksheets("12 د بنون")
End Property
Public Property Get lr() As Long: lr = F.Columns("C:J").Find(What:="*", _
                SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
End Property

Sub Sort_Names()
 'ترتيب ابجدي
Dim OneRng As Range
  Set OneRng = F.Range("C11:J" & lr)
  With OneRng
    .Sort Key1:=.Columns(1), Order1:=xlAscending, Header:=xlNo
  End With
End Sub
'***********
Sub Sort_TOTAL()
'ترتيب تنازلي
Dim OneRng As Range
  Set OneRng = F.Range("C11:J" & lr)
  With OneRng
    .Sort Key1:=.Columns(7), Order1:=xlDescending, Header:=xlNo
  End With
End Sub
'*********
Sub Sort_TOTAL2()
'ترتيب تصاعدي
Dim OneRng As Range
  Set OneRng = F.Range("C11:J" & lr)
  With OneRng
    .Sort Key1:=.Columns(7), Order1:=xlAscending, Header:=xlNo
  End With
End Sub

فرز Final.xlsb

يونيو 29, 2024

وعليكم السلام ورحمة الله تعالى وبركاته

اعتقد اخي الفاضل ان انسب طريقة لدالك هي استخراج القيم التي يساوي مجموعها القيمة المدخلة في عمود مغاير لان الاعتماد على التظليل ممكن يسبب لك تداخل في النتائج المتوقعة

عند تواجد نفس الرقم في اكثر من احتمال

مثال لو اردنا استخراج الاعداد الخاصة ب 34 مع وجود الارقام التي قمت بدكرها في مشاركتك سنعثر على نفس الارقام مكررة في اكثر من احتمال 👇

1.PNG.bb8e8c84d74bd2e9a8f75a8d0bb88ab6.PNG

لتتفادى هدا ممكن استخدام الدالة التالية

مثال لعملية استخراج القيم المتوقعة 👈

لنفترض ان الخلية المخصصة لادخال المجموع هي B2

In cell B2

=IFERROR(TRANSPOSE(xFormula(A2:A11; B2));"")

وفي Module انسخ الكود التالي مع حفظ الملف بصيغة الماكرو

Option Explicit
'================29/06/2024     by:MOHAMEED HICHAM    www.officena.net     "منتدى الاكسيل" '
'===========================================================================================
Public Function xFormula(rngNumbers As Range, XSum As Long)
Dim arNumbers() As Long, tmp() As Long, arr() As String, F As Range, Cnt As Long
    ReDim arr(0)
    If rngNumbers.Count > 1 Then
      ReDim arNumbers(rngNumbers.Count - 1)
      Cnt = 0
      For Each F In rngNumbers
          arNumbers(Cnt) = CLng(F.Value)
          Cnt = Cnt + 1
      Next F
      Call Cpt(arNumbers, XSum, tmp(), arr())
  End If
  ReDim Preserve arr(0 To UBound(arr) - 1)
  xFormula = arr
End Function
Private Sub Cpt(Numbers() As Long, target As Long, tmp() As Long, ByRef arr() As String)
    Dim s As Long, i As Long, j As Long, num As Long
    Dim Rng() As Long, tmpRec() As Long, n As Long
    s = a(tmp)
    If s = target Then
       n = UBound(arr)
       ReDim Preserve arr(0 To n + 1)
       arr(n) = b(tmp)
    End If
    If s > target Then Exit Sub
    If (Not Not Numbers) <> 0 Then
        For i = 0 To UBound(Numbers)
            Erase Rng()
            num = Numbers(i)
            For j = i + 1 To UBound(Numbers)
                Total Rng, Numbers(j)
            Next j
            Erase tmpRec()
            C tmpRec, tmp
            Total tmpRec, num
            Cpt Rng, target, tmpRec, arr
        Next i
    End If
End Sub
Private Function b(x() As Long) As String
    Dim n As Long, result As String
    result = " " & x(n)
    For n = LBound(x) + 1 To UBound(x)
        result = result & "-" & x(n)
    Next n
    result = result & " "
    b = result
End Function
Private Function a(x() As Long) As Long
    Dim n As Long
    a = 0
    If (Not Not x) <> 0 Then
        For n = LBound(x) To UBound(x)
            a = a + x(n)
        Next n
    End If
End Function
Private Sub Total(arr() As Long, x As Long)
    If (Not Not arr) <> 0 Then
        ReDim Preserve arr(0 To UBound(arr) + 1)
    Else
        ReDim Preserve arr(0 To 0)
    End If
    arr(UBound(arr)) = x
End Sub
Private Sub C(destination() As Long, source() As Long)
    Dim n As Long
    If (Not Not source) <> 0 Then
        For n = 0 To UBound(source)
                Total destination, source(n)
        Next n
    End If
End Sub

ادا كنت تستخدم النسخ الحديثة من الاوفيس ضع المعادلة التالية في الخلية E2 للتحقق من مجموع القيم المستخرجة مع سحبها للاسفل

=IF(D2<>"";SUM(FILTERXML("<x><y>"&SUBSTITUTE(TRIM(CONCAT(IFERROR(0+MID(D2;SEQUENCE(LEN(D2));1);" ")));" ";"</y><y>")&"</y></x>";"//y"));"")

فحص مجموعة قيم لايجاد اى منها يساوى قيمة معينة.xlsm

يونيو 28, 2024

غريب صراحة لا اعلم لمادا لانني جربت الملف عندي ويشتغل بشكل جيد و بدون ادنى مشكلة

وللتأكد قمت بتجربته على جهاز اخر انظر الرابط التالي 👇

https://streamable.com/3m40n4

رغم انني متأكد من صحة الاكواد وبما ان كود التنازلي يعمل جرب هدا للتصاعدي و الترتيب الابجدي ووافينا بالنتيجة

Sub Tri_Names_Ordre()
 'ترتيب ابجدي
Dim a()
Dim r As Range
  a = f.Range("C11:J" & f.[C65000].End(xlUp).Row).Value
  Set r = f.Range("C11:J" & f.[C65000].End(xlUp).Row)
   ' <<=======عمود الاسم========
   Call Quick(a(), LBound(a), _
          UBound(a), 1, True): r.Value2 = a
End Sub
'*************
Sub Tri_Ordre_croissant()
'ترتيب تصاعدي
Dim a()
Dim r As Range
  a = f.Range("C11:J" & f.[C65000].End(xlUp).Row).Value
  Set r = f.Range("C11:J" & f.[C65000].End(xlUp).Row)
   ' <<=======عمود المجموع========
   Call Quick(a(), LBound(a), _
          UBound(a), 7, True): r.Value2 = a

End Sub

فرز V4.xlsb

يونيو 28, 2024

45 دقائق مضت, محمد زيدان2024 said:

جهد مشكور بس الاكود لازم ادوس عليها مرتين علشان تشتغل

انت لم تنتبه انه لديك نفس قيمة المجموع للاسماء 🤔🤔🤔

فارس محمد عبد الرازق اسماعيل 676

عمار سيد عبد الرازق اسماعيل 676

الكود يقوم بتحديثها جرب تغيير الرقم وسوف تلاحظ الفرق

Capturedcran2024-06-28221735.png.1df7454efffb9c97777196f57355766e.png

يونيو 28, 2024

تفضل اخي @محمد زيدان2024 تم تعديل الاكواد لتتناسب مع طلبك

Capturedcran2024-06-28211835.png.50ec576d5fbdf7ae720feffc38993b7c.png

Option Compare Text
Public Property Get f() As Worksheet: Set f = Worksheets("12 د بنون")
End Property
'================29/06/2024     by:MOHAMEED HICHAM    www.officena.net     "منتدى الاكسيل" '
'===========================================================================================
Sub TriTotal_Descending_Order()
'ترتيب تنازلي
Dim a()
Dim r As Range

  a = f.Range("C11:J" & f.[C65000].End(xlUp).Row).Value
  Set r = f.Range("C11:J" & f.[C65000].End(xlUp).Row)
  
  ' تحديد نطاق معين
   'a = [C11:J38].Value: Set r = [C11:J38]
   
   ' <<=======عمود المجموع========
   Call Quick(a(), LBound(a), _
          UBound(a), 7, False): r.Value2 = a
End Sub
'**********فرز سريع*************
Sub Quick(a(), gauc, droi, Cnt, ordre)
 Total = a((gauc + droi) \ 2, Cnt)
 Rng = gauc: d = droi
 Do
  If ordre Then
    Do While a(Rng, Cnt) < Total: Rng = Rng + 1: Loop
    Do While Total < a(d, Cnt): d = d - 1: Loop
  Else
    Do While a(Rng, Cnt) > Total: Rng = Rng + 1: Loop
    Do While Total > a(d, Cnt): d = d - 1: Loop
  End If
   If Rng <= d Then
     For i = LBound(a, 2) To UBound(a, 2)
       temp = a(Rng, i): a(Rng, i) = a(d, i): a(d, i) = temp
     Next i
     Rng = Rng + 1: d = d - 1
   End If
  Loop While Rng <= d
  If Rng < droi Then Call Quick(a, Rng, droi, Cnt, ordre)
  If gauc < d Then Call Quick(a, gauc, d, Cnt, ordre)
End Sub
'************************************
Sub Tri_Colmun_Name()
 'ترتيب ابجدي
 Dim clé() As String, index() As Long, Rng As Range
 a = f.Range("C11:J" & f.[C65000].End(xlUp).Row).Value
 Dim b(): Set Rng = f.[C11]
 ReDim b(LBound(a) To UBound(a), LBound(a, 2) To UBound(a, 2))
 Set rCrit = CreateObject("System.Collections.Sortedlist")
 For i = LBound(a) To UBound(a)
   rCrit.Add a(i, 1) & i, i
 Next i
 For tmp = LBound(a) To UBound(a)
  For arr = LBound(a, 2) To UBound(a, 2)
    b(tmp, arr) = a(rCrit.GetByIndex(tmp - 1), arr)
  Next arr
 Next tmp
Rng.Resize(UBound(b), UBound(b, 2)).Value2 = b
End Sub
'*************************************
Sub Tri_Total_Colmun()
'ترتيب تصاعدي
 Dim clé() As String, index() As Long, Rng As Range
 a = f.Range("C11:J" & f.[C65000].End(xlUp).Row).Value
 Dim b(): Set Rng = f.[C11]
 ReDim b(LBound(a) To UBound(a), LBound(a, 2) To UBound(a, 2))
 Set rCrit = CreateObject("System.Collections.Sortedlist")
 For i = LBound(a) To UBound(a)
   rCrit.Add a(i, 7) & i, i
 Next i
 For tmp = LBound(a) To UBound(a)
  For arr = LBound(a, 2) To UBound(a, 2)
    b(tmp, arr) = a(rCrit.GetByIndex(tmp - 1), arr)
  Next arr
 Next tmp
Rng.Resize(UBound(b), UBound(b, 2)).Value2 = b
End Sub

فرز V3.xlsb

يونيو 28, 2024

تمام اخي محمد

يونيو 28, 2024

طلبك غير واضح بالنسبة لي ربما لم استطع استوعابه يمكنك شرح المطلوب بشكل اكثر وضوحا عند الاجابة على هده الاسئلة

اخي @محمد زيدان2024 ادا قمنا بترتيب كل عمود على حدى هدا سياثر على صحة البيانات المجاورة من تاريخ الميلاد وحتى عمود السنة

في حالة قمنا بفرز عمود الاسم ابجديا مع تحديد جميع البيانات هدا من شانه ان ياثر على ترتيب عمود المجموع وعند محاولة ترتيبه هو الاخر سيأثر على بياناتك سوف يصبح مجموع محمد مثلا يقابل اسم جرجس

يونيو 28, 2024

2 ساعات مضت, muhandesramadan said:

عند اختيار القضاء (دهوك) وعند عدم اختيار الناحية و القرية تعطيني الحي (حي الشرطة)

حاولت البحث عن عبارة حي الشرطة لم اجدها في عمود القرية هل هده اللغة السندية

يونيو 28, 2024

اخي الفاضل بما انك تريد شكل القوائم متتابعة و مترابطة لابد من اختيار القيم المرغوب تعبئتها على القوائم بطريقة هي الاخرى متتابعة لا يمكنك الاعتماد على الفراغات داخل المعادلة ولا اعتقد انه هناك معادلة من شانها فعل دالك بالطريقة المطلوبة على حسب علمي المتواضع

لا اعلم عن طريقة اشتغالك على الملف ولا الهدف من وراء انشاء هده القوائم لاكن مجرد فكرة من شانها مساعدتك

اظن ان استخدام الاكواد من الممكن ان يساعدك في هدا ويمكنك نوعا ما من تجاهل الفراغات داخل القوائم واعتبارها قيمة بحث

بمعنى ادخال قيمة الصف الاول ولتكن (دهوك) على القائمة الاولى واختيار قيمة فارغة في القائمة 2 و 3 مثلا للحصول على على قيمة الصف الرابع التي يقابلها شرط دهوك في الصف 1 والفراغات في الصف 2 و3 وهكدا مع القوائم الخمس . واخيرا ترحيل القيم المختارة للجدول الثاني اسفل بعضها

ادا لم يكن عندك مانع لاستخدامها يكفي انشاء يوزرفورم صغير على الملف يتضمن 5 Combobox وزر وسوف احاول كتابة الاكواد الخاصة بدالك للتجربة

يونيو 28, 2024

'In cell P4
=UNIQUE(FILTER(B5:B300,B5:B300<>""))

'In cell Q4
=SORT(UNIQUE(FILTER(C5:C300,(C5:C300 <>"")*( B5:B300=I5),"")))

'In cell R4
=SORT(UNIQUE(FILTER(D5:D300,(D5:D300 <>"")*( B5:B300=I5)*( C5:C300=J5),"")))

'In cell S4
=SORT(UNIQUE(FILTER(E5:E300,(E5:E300 <>"")*( B5:B300=I5)*( C5:C300=J5)*( D5:D300=K5),"")))

'In cell T4
=SORT(UNIQUE(FILTER(F5:F300,(F5:F300 <>"")*( B5:B300=I5)*( C5:C300=J5)*( D5:D300=K5)*( E5:E300=L5),"")))

Create drop-down lists

Cells i5 =$P$4# / Cells j5  =$Q$4# / Cells k5 =$R$4# / Cells L5 =$S$4# / Cells M5 =$T$4#

عمل قائمة منسدلة.xlsx

يونيو 27, 2024

العفو أخي سعد يسعدنا أننا إستطعنا مساعدتك

بالتوفيق.

يونيو 26, 2024

لم اجد الكود داخل الملف ولا اعلم اسم الورقة المرغوب تنفيد الكود عليها

يونيو 26, 2024

اذا كنت قد فهمت طلبك بشكل صحيح فالتعديل التالي سوف يوفي بالغرض

Option Compare Text
Dim a, i As Long
Dim OneRng(), Rng, rCrit1, rCrit2
Dim d As Object, ComboAry As Variant
Private Const Cpt As String = "Compte magasin"
Private Const tbl As String = "Table1"
Dim Crit(), headers(), choix(), colClé, Cnt, Item_Code
Private Sub UserForm_Initialize()
Dim Irow&
Set f = Sheets(Cpt)
a = Sheets(Cpt).ListObjects("Table1").DataBodyRange.Columns("A:X")
Set d = CreateObject("scripting.dictionary")
    d.CompareMode = vbTextCompare
   Irow = f.Columns("I:N").Find(What:="*", SearchDirection:=xlPrevious, _
                                              SearchOrder:=xlByRows).Row
                                              
 Set Cnt = f.Range("G2:N" & Irow): Crit = Cnt.value
 headers = Application.Index(Cnt.Offset(-1).value, 1)
  Me.ComboBox10.List = Application.Transpose(f.Range("J1:N1").value)
   ComboAry = Array("ComboBox1", "ComboBox3", "ComboBox5", _
                  "ComboBox9", "ComboBox10", "ComboBox13", "ComboBox12")
   For i = 0 To UBound(ComboAry): Me.Controls(ComboAry(i)).value = "*": Next i

'''''''' Code.....
 '''''''''''''''''''''

End Sub
********************************************************************
Private Sub ComboBox10_Change()
Item_Code = Val(Me.ComboBox12): Prices = Me.ComboBox10
  If IsNumeric(Me.ComboBox10) Then _
       tmp = Val(Me.ComboBox10) Else tmp = Prices
  colClé = Application.Match(tmp, headers, 0)
  For i = LBound(Crit) To UBound(Crit)
    If UCase(Crit(i, 1)) = UCase(Item_Code) And _
  Prices <> "*" Then Me.TextBox7.value = Crit(i, colClé)
  Next i
 End Sub

بيانات فاتورة 3.xlsm

يونيو 26, 2024

ارفق ملفك أخي الكريم ليتم إسقاط الكود للتجربة مع توضيح شكل البيانات المتوقع

يونيو 26, 2024

ماذا تقصد هل قمت بحل المشكلة بخصوص الطلب الثاني !!

يونيو 25, 2024

الكود بطريقة اخرى مع الشرح لتتمكن من تعديله بما يناسبك

Public Sub CopyData2()
    Dim rCrit() As String: ReDim rCrit(1 To 2): Const SrcRow = "EA"
    Dim x&, i&, Cnt&, arr&, lr&, lastRow&, Cpt As Long
    Dim Search_Row As Long, Star_Row As Long, Col As Range
    Dim rngA As Variant, rngB As Variant, OneRng As Range
    Dim WS As Worksheet: Set WS = Sheets("cheet4")
    Dim srcWS As Worksheet: Set srcWS = Sheets("شيت الدور الثاني صف رابع ")
   
 ' تحديد صف البداية
    Star_Row = 16:
   
' عمود الفلترة
     Search_Row = 131
     
 'تحديد صف وضع البيانات المرحلة
    Cnt = 10
    
    
With Application
 .ScreenUpdating = False
 .Calculation = xlManual
 
 lastRow = WS.Range(SrcRow & WS.Rows.Count).End(xlUp).Row
 
 lr = srcWS.Columns("C:AP").Find(What:="*", _
             SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
             
 'معايير الفلترة
rCrit(1) = "غ": rCrit(2) = "*" & "دور ثان" & "*"
'الاعمدة المرحلة
rngA = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, _
                 28, 40, 52, 64, 76, 88, 100, 112, 116, Search_Row)
 'الاعمدة المرحل اليها
rngB = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, _
                     15, 18, 21, 24, 27, 30, 33, 36, 39, 42)
'("EA")'التحقق من وجود المعايير على عمود 
arr = Application.Sum _
        (Application.IfError(Application.Match(rCrit, WS.Columns(Search_Row), 0), 0))
        If arr = 0 Then: MsgBox " المرجوا التحقق من صحة المعايير ", _
                                     vbCritical, "انتباه": Exit Sub
   'افراغ البيانات السابقة
For x = 0 To UBound(rngB)
    Set Col = srcWS.Range(srcWS.Cells(Cnt, rngB(x)), srcWS.Cells(lr, rngB(x)))
      Col.ClearContents
       Next x
With WS
    If .AutoFilterMode Then .AutoFilterMode = False
 ' تحديد نطاق البيانات
 With WS.Range("C15:EA15")
    .AutoFilter Search_Row - 2, rCrit, xlFilterValues
 ' نسخ الاعمدة المرئية
 For i = 0 To UBound(rngA)
    Set OneRng = WS.Range(WS.Cells(Star_Row, _
     rngA(i)), WS.Cells(lastRow, rngA(i))).SpecialCells(xlCellTypeVisible)
     
    OneRng.Copy
    'لصق البيانات
     srcWS.Cells(Cnt, rngB(i)).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        Next i
      .AutoFilter
    End With
End With

  .CutCopyMode = False
 .Calculation = xlAutomatic
.ScreenUpdating = True
End With

End Sub

SAAD V3.xlsm

يونيو 25, 2024

26 دقائق مضت, 2saad said:

هل هي السبب في عدم عمل الكود ؟

لا اخي ليس لها علاقة الملف يشتغل معي بشكل جيد جدا وبدون ادنى مشكلة

ما هو اصدار الاوفيس لديك اخي سعد

تسجيل الدخول

المنتدى

مكتبة الموقع

معرض الصور

المدونات

الوسائط المتعددة

مشاركات المكتوبه بواسطه محمد هشام.

Important Information