سليم حاصبيا

جرب هذا الكود Option Explicit Sub Colorize_Range() 'Created By Salim Hasbaya 9/6/2109 Dim i%, x%, k%, m%, My_ad$, First_ad$ Dim My_rg As Range, cel As Range Set My_rg = Range("a1:G12") Dim f_rg As Range x = 4 My_rg.Interior.ColorIndex = xlNone For Each cel In My_rg If cel.Interior.ColorIndex <> xlNone Or _ Application.CountIf(My_rg, cel) = 1 Then _ GoTo next_cel Set f_rg = My_rg.Find(cel, lookat:=xlWhole) My_ad = f_rg.Address: First_ad = My_ad Do Range(My_ad).Interior.ColorIndex = x Set f_rg = My_rg.FindNext(f_rg) My_ad = f_rg.Address Loop Until My_ad = First_ad x = x + 1: If x = 57 Then x = 10 next_cel: Next cel End Sub الملف مرفق CororisMe.xlsm

بعد اذن الاساتذة الكرام هذا الماكرو Option Explicit Sub get_data() Dim B As Worksheet: Set B = Sheets("BASMMA") Dim N As Worksheet: Set N = Sheets("NASHER") Dim Dic As New Dictionary Dim i%: i = 2 Dim x With N Do Until .Range("B" & i) = vbNullString If Not Dic.Exists(.Range("B" & i).Value) Then Dic.Add .Range("B" & i).Value, .Range("F" & i).Resize(, 59).Value End If i = i + 1 Loop B.OLEObjects("Combobox1").Object.List = Dic.Keys End With x = N.Range("B:b").Find(B.Range("h2")).Row With B .Range("a2") = N.Cells(x, 1) .Range("b2") = N.Cells(x, 2) .Range("c2") = N.Cells(x, 4) .Range("e2").Resize(59, 1).Value = _ Application.Transpose(Dic.Items(x - 2)) End With Dic.RemoveAll End Sub الملف مرفق Salim_Search.xlsm

جرب هذا الكود Option Explicit Sub Tarhil() Dim My_St: My_St = Sheets("data").Range("b1") Dim My_col% My_col = Sheets("tab").Range("A1:F1").Find(My_St).Column Sheets("data").Range("b2", Range("b1").End(4)).Copy _ Sheets("tab").Cells(2, My_col) End Sub

لبس من الضروري ان يكون نفس المتفير MyID الرسالة تعطيك مثالاُ عما يجري فتش عن المتغير المكرر في الاكواد عندك هذا نتيجة عدم استعمال Option Explicit في بداية كل كود

فقط امسح Dim MyID As String من السطر الاول

المتغيير ID as srting مكتوب مرتين في السطر الاول والرابع

اذا اردت التوزبع عشوائي هذا الماكرو Option Explicit Sub choose_rnd() '============================================= Rem this Macro distributs all numbers bettween Two given Ones _ In Columns with fixed lenght(by Choise) _ without repetition _ ========>> Created by_salim hasbaya On 6/6/2019 '============================================= If ActiveSheet.Name <> "SALIM" Then Exit Sub Dim i% Dim myStart%: myStart = Application.Min([c2:c3]) Dim myEnd%: myEnd = Application.Max([c2:c3]) Range("c2").CurrentRegion.Offset(2, 1).ClearContents If Not IsNumeric([a2]) Or [a2] < 1 _ Or Int([a2]) <> [a2] Then [a2] = 50 Dim Max_ro%: Max_ro = [a2] + 2 If Max_ro > 102 Then Max_ro = 52 Dim r%, c% r = 3: c = 4 With CreateObject("System.Collections.SortedList") For i = myStart To myEnd .Item(Rnd) = i Next i i = 0 Do Until i > .Count - 1 Cells(r, c) = .GetByIndex(i) r = r + 1 If r = Max_ro + 1 Then r = 3: c = c + 1 i = i + 1 Loop End With End Sub الملف مرفق Rnd _Distribution.xlsm

لم افهم ما تقصده تشرفت بمروركم الكريم استاذ عادل

بعد اذن الاستاذ عادل زيادة في اثراء الموضوع هذا الكود Private Sub CommandButton1_Click() Dim My_min#: My_min = Application.Min([b2:b3]) Dim My_max#: My_max = Application.Max([b2:b3]) Dim i#, c%, r%, Max_ro% c = 4: r = 3: Max_ro = 52 Range("b2").CurrentRegion.Offset(1, 2) = vbNullString For i = My_min To My_max Cells(r, c) = i r = r + 1 If r = Max_ro + 1 Then: r = 3: c = c + 1 Next End Sub

الملف بصيغة 2003 اذا كان الكومبوبوكس في الصفحة T فارغاً اخرج من الصفحة ثم عد اليها DALIM.xls

وكيف يمكن تحديد خلية (أو الوقوف عندها )وكل الصف لهذه الحلية مخفي بواسطة الفلتر

ربما تنفع مجموع الأكواد هذه بجيث تختار المادة التي تريد اذا كان الكومبوبوكس في الصفحة T فارغاً اخرج من الصفحة ثم عد اليها Private Sub My_Combo_Change() Rem ======>> Created By Salim Hasbaya On 5/6/2019 Tajriba End Sub Rem ==================================== Private Sub Worksheet_Activate() Rem ======>> Created By Salim Hasbaya On 5/6/2019 fil_comBo End Sub Option Explicit Rem ======>> Created By Salim Hasbaya On 5/6/2019 Sub Tajriba() Dim tt As Worksheet: Set tt = Sheets("T") Dim M As Worksheet: Set M = Sheets("Matharive") Dim Madda$: Madda = tt.Range("B2") Dim col%, My_count Dim x_ro%: x_ro = 5 Dim Y_col%: Y_col = 4 Dim Max_ro%, Frst_ad$, Act_ad$ Dim find_what As Range Dim Searh_rg As Range Dim t% Dim Ro% tt.Range("d5:v" & Rows.Count).ClearContents Max_ro = M.Range("t1").CurrentRegion.Rows.Count col = Sheets("MaTharive").Range("T1:ba1").Find(Madda).Column Set Searh_rg = Sheets("MaTharive").Cells(1, col).Resize(Max_ro) My_count = Application.CountIf(Searh_rg, Madda) - 1 Set find_what = Searh_rg.Find(Madda) If find_what Is Nothing Then Exit Sub Act_ad = Searh_rg.Find(Madda).Address Frst_ad = Act_ad Ro = find_what.Row Do t = t + 1 If t > My_count Then Exit Do tt.Cells(x_ro, Y_col) = M.Cells(Ro, "T") x_ro = x_ro + 1 If x_ro = 55 Then x_ro = 5: Y_col = Y_col + 1 Set find_what = Searh_rg.FindNext(find_what) Act_ad = find_what.Address Ro = find_what.Row If Act_ad = Frst_ad Then Exit Do Loop End Sub Rem================================== Sub fil_comBo() Dim MY_Array(1 To 18) Dim i MY_Array(1) = 21: MY_Array(2) = 25: MY_Array(3) = 27 MY_Array(4) = 29: MY_Array(5) = 31: MY_Array(6) = 33 MY_Array(7) = 35: MY_Array(8) = 37: MY_Array(9) = 38 MY_Array(10) = 40: MY_Array(11) = 42: MY_Array(12) = 43 MY_Array(13) = 45: MY_Array(14) = 46: MY_Array(15) = 47 MY_Array(16) = 49: MY_Array(17) = 50: MY_Array(18) = 51 For i = 1 To 18 MY_Array(i) = _ Sheets("MaTharive").Cells(1, MY_Array(i)) Next Sheets("t").My_Combo.List = Application.Transpose(MY_Array) Erase MY_Array End Sub الملف مرفق Dalil.xlsm

انت ترفع ملف Word و تريد الاجابة عن سؤال في Excel

من جديد فالقائمة المنسدلة المطلوبة يجب أن تحتوي علي اسم العامل واسم المنتج و الكمية المطلوبة

اذا كان هذا ما تريد اضغط على علامة الصح (أفضل اجابة) حتى لا تتكرر الردود

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

جرب هذا الكود Sub give_data() Application.ScreenUpdating = False Dim x As Byte x = Application.CountA(Sheets("SAISIE").Range("B1:B6")) If x < 6 Then MsgBox "Incomplete Data" & Chr(10) & _ "You have Only " & x & " Values": GoTo Exit_sub Sheets("SAISIE").Range("B1:B6").Copy Sheets("DATA").Range("A" & Rows.Count).End(3).Offset(1) _ .PasteSpecial Paste:=xlPasteAll, Transpose:=True Sheets("SAISIE").Range("B1:B6").ClearContents Exit_sub: Application.ScreenUpdating = True End Sub الملف مرفق COPY-VBA.xlsm

اعتذر عن الاجابة لان الملف محمي بكلمة سر وكذلك الماكرو بداخله ولا يمكن الاطلاع على اي معادلة أو كود فكيف لي ان اساعدك

تجربة Option Explicit Sub code_with_MsgBox() Dim Answer As Byte Range("a1") = vbNullString Answer = MsgBox("Can not undo...Continue?", 4) If Answer = 6 Then Range("a1") = "The Code Wase running" End If End Sub

قم بادراج بعض النتائح المتوقعة (يدوياً) في الملف p مع شرح مضدرها لنعرف بالضبط ما المطلوب

الرمز % هو اختصار لعبارة As Integer

جرب هذا الشيء Compare.xlsx

لا أفهم لما وجود 3 مصنفات حيث يمكن ادراج كل البيانات في شيت واحدة في مصنف واحد

فقط حدد لي اي ورقة هي المصدر للمعلومات واي ورقة هي الهدف (انا لا افهم ما تقصده) اذ كانت ورقة المبيعات هي الهدف فما الفائدة من تكرار اسماء الأصناف فيها 3 مرات الصنف 1 / 5 مرات الصنف 2 الخ.... يكفي ان تدرج كل صنف من ورقة الاصناف مرة واحدة في ورقة المبيعات وفي حال ادراج صتف جديد تتم اضافته في ورقة المبيعات

بعض الاسماء غير موجودة بالعامود B ربما هناك مسافات زائدة او ناقصة صحح الاسماء ثم سنقوم بايجاد الحل شاهد الملف Correction.xlsx