سليم حاصبيا

تم تغيير الكود(انسخه الى موديل جديد و عين له زراً للتنفيذ)
Option Explicit Option Base 1 Sub Salim_Extract() Dim Src_Sh As Worksheet Dim Trg_Sh As Worksheet Dim xx, lr, m, My_Row As Integer Dim ArrJ(), ArrG() Dim t As Long Application.ScreenUpdating = False My_Row = 4 Set Trg_Sh = Sheets("الديون") Trg_Sh.Range("e4").Resize(10000, 3).Clear For m = 3 To Sheets.Count - 2 t = 1 Set Src_Sh = Sheets(m) With Src_Sh .Select On Error GoTo 1 On Error Resume Next lr = .Cells(Rows.Count, "j").End(3).Row For xx = 4 To lr If .Cells(xx, "j") > 0 And Cells(xx, "j") <> "" Then ReDim Preserve ArrJ(t) ReDim Preserve ArrG(t) ArrJ(t) = .Cells(xx, "j").Value ArrG(t) = .Cells(xx, "G").Value: t = t + 1 End If Next End With Trg_Sh.Range("g" & My_Row).Resize(UBound(ArrJ)) = Application.Transpose(ArrJ) Trg_Sh.Range("f" & My_Row).Resize(UBound(ArrG)) = Application.Transpose(ArrG) Trg_Sh.Range("e" & My_Row).Resize(UBound(ArrG)) = Sheets(m).Cells(1, 2) Trg_Sh.Range("f" & My_Row).Resize(UBound(ArrG)).NumberFormat = "m/d/yyyy" My_Row = My_Row + t Trg_Sh.Range("e" & My_Row - 1).Resize(, 3).Interior.ColorIndex = 6 1: Erase ArrJ: Erase ArrG Next Application.ScreenUpdating = True Trg_Sh.Activate: Range("e3").Select End Sub الملف المرفق 
اصنافform salim 1.rar

لتجاوز الاحطاء تم تعديل الكود
Sub transfer_with_ٍSalim1() Dim Sht_Source, Sht_Target As Worksheet Dim lr1, lr2, My_Row, My_Column As Integer Dim My_Name As String, Oldsum Dim My_Error As Long Set Sht_Source = Sheets("المكافآة"): Set Sht_Target = Sheets("تجميع المكافآت على مدار العام") lr1 = Sht_Source.Cells(Rows.Count, 1).End(3).Row lr2 = Sht_Target.Cells(Rows.Count, 1).End(3).Row My_Column = Application.Match(Sht_Source.Range("d2"), Sht_Target.Range("c4:n4"), 0) + 2 For i = 5 To lr1 On Error Resume Next My_Name = Sht_Source.Range("b" & i).Value My_Row = Application.Match(My_Name, Sht_Target.Range("b5:b" & lr2), 0) + 4 '============================================== My_Error = Err.Number: If My_Error <> 0 Or My_Name = "" Then GoTo 1 Oldsum = Sht_Target.Cells(My_Row, My_Column) Sht_Target.Cells(My_Row, My_Column) = Oldsum + Sht_Source.Cells(i, 3) '============================================== 1: My_Error = 0 Next End Sub  

ربما كان المطلوب
 
Extract_num_Or_letters.rar

ربما يكون المطلوب
 
 
مثال salim.zip

ربما كان المطلوب
الاسماء تضاف تلقائيا الى الكومبو و ترتب ابجدياً بدون تكرار
 
form1.rar

تم التعديل غلى الملف ليظهر كل الاسماء حسب البحث دفعة وحدة
 
تعديل احمد عبد الرحمن salim.rar

الصفحة "Salim" من هذا الملف
Marwa.xlsm

جرب هذا لملف
 
Chidren.zip

جرب هذا الملف
الماكرو في الصفحة الاولى (حينما تغير اي شيء في العامود الاول يغمل الماكرو تلقائياً بشرط ان يكون التغيير في خلية واحدة)
بالنسبة للسؤال الثاني انظر الى الصفحة 2
work_with_5.rar

هذه المعادلة
=IF(OR(C3<1,C3>12,ISTEXT(C3)),"",13-C3)  

اليك الحل على طريقتين
m_79.rar

ربما كان المطلوب
Faris.xlsx

جرب هذه الملف في النطاق A2:k11 (يمكن تعديل هذا النطاق من داخل الكود)
الكود مرفق
Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim my_rg As Range Dim col%, r%, x%, t% Application.EnableEvents = False Set my_rg = Range("a2:k11") If Intersect(Target, my_rg) Is Nothing Then GoTo 1 If Target.Rows.Count <> 1 Then GoTo 1 r = Target.Row: col = Target.Column t = Cells(r, 1).End(xlToRight).Column: If t > 11 Then t = 1 x = Application.CountA(Range(Cells(r, 1), Cells(r, col))) If x <> col Then MsgBox ("Out Of range") Target.Value = vbNullString If t = 1 Then Cells(r, 1).Select Else Cells(r, t + 1).Select End If End If 1: Application.EnableEvents = True End Sub الملف 
No_cells_to_skeep.rar

=LEN(TRIM(A1))-LEN(SUBSTITUTE(TRIM(A1)," ",""))+1 لمعرفة عدد الكلمات هذه المعادلة
لمعرفة عدد الفراغات  هذه الثانية
=LEN(TRIM(A1))-LEN(SUBSTITUTE(TRIM(A1)," ",""))  
 
 

حرب هذا الملف
لا ضرورة لادراج اكثر من 700 صف
لان المكرو الذي يعمل على صف واجد يستطيع العمل على الألوف منها
يكفي ادراج نموذح بسيط لما تريد (50 صف كحد أقصى)
كما اني لم أفهم ما هي  الحاجة الى اليوزر فورم؟؟؟
Option Explicit Sub Get_data() Dim H As Worksheet Dim T As Worksheet Dim LrH%, LrT%, i%, Sd#, _ k%, Se#, My_val#, n% Dim Date1 As Date, Date2 As Date Dim M_date As Date, X_date As Date Dim Fr As Range, Wat As Range, Ro1%, Ro2% Dim x As Boolean, y As Boolean Set H = Sheets("Haraka") Set T = Sheets("Takrir") LrH = H.Cells(Rows.Count, 1).End(3).Row LrT = 20 T.Range("D5").Resize(LrT, 3).ClearContents Date1 = Application.Min(H.Range("C4:C" & LrH)) Date2 = Application.Max(H.Range("C4:C" & LrH)) If Not IsDate(T.Range("D2")) Or Not IsDate(T.Range("E2")) Then MsgBox "Please Type Dates in D2 and E2" Exit Sub End If M_date = T.Range("D2"): X_date = T.Range("E2") If Not IsDate(T.Range("D2")) Or Not IsDate(T.Range("E2")) Then MsgBox "Wrong Dates" Exit Sub End If T.Range("D2") = Application.Min(M_date, X_date) T.Range("E2") = Application.Max(M_date, X_date) M_date = T.Range("D2"): X_date = T.Range("E2") Set Wat = H.Range("A3:A" & LrH) For i = 5 To LrT Set Fr = Wat.Find(T.Range("B" & i), lookat:=1) If Fr Is Nothing Then GoTo Again Ro1 = Fr.Row: Ro2 = Ro1 Do x = H.Range("C" & Ro2) >= M_date y = H.Range("C" & Ro2) <= X_date If x And y Then Sd = Sd + Val(H.Range("D" & Ro2)) Se = Se + Val(H.Range("E" & Ro2)) n = n + 1 End If Set Fr = Wat.FindNext(Fr) Ro2 = Fr.Row If Ro2 = Ro1 Then Exit Do Loop T.Range("D" & i) = IIf(Sd = 0, "", Sd) T.Range("E" & i) = IIf(Se = 0, "", Se) My_val = Val(T.Range("C" & i)) + Val(T.Range("D" & i)) _ - Val(T.Range("E" & i)) T.Range("F" & i) = IIf(My_val = 0, "", My_val) T.Range("G" & i) = IIf(n = 0, "", n) Again: Sd = 0: Se = 0: n = 0 Next i End Sub T_Mansour.xlsm

Try This File
Jalal.xlsx

اذا كان ما فهمته صحيحاً هذا الكود (فقط اضغط الزر Run)
Option Explicit Sub Creezy_sort() Dim CoL As Object Dim Lr%, i%, x% Dim arr Dim Ws As Worksheet Set Ws = Sheets("EN") With Ws .Range("E1").CurrentRegion.Offset(1).ClearContents Set CoL = CreateObject("System.Collections.sortedlist") Lr = .Cells(Rows.Count, 1).End(3).Row For i = 2 To Lr CoL.Add Len(.Cells(i, 1)) + i / 1000, .Cells(i, 1) & _ "*" & .Cells(i, 2) Next i x = 2 For i = 0 To CoL.Count - 1 .Cells(x, "E") = Split(CoL.GetByIndex(i), "*")(0) .Cells(x, "F") = Split(CoL.GetByIndex(i), "*")(1) arr = Split(Split(CoL.GetByIndex(i), "*")(1), ",") .Cells(x, "G") = UBound(arr) + 1 x = x + 1 Next End With Set Ws = Nothing: Set CoL = Nothing End Sub الملف مرفق
Hitari.xlsm

فقط تغيير المعطيات
Option Explicit '++++++++++++++++++++++++++++++ Dim Ra As Range, Rb As Range Dim a%, b%, i%, Bol As Boolean Dim m%, t% Dim Ky Dim S As Worksheet Dim Dic_Unique As Object Dim Dic As Object '++++++++++++++++++++++++++++++++++++++ Sub Item_Unique() Set S = Sheets("Salim") Set Dic = CreateObject("Scripting.Dictionary") Set Dic_Unique = CreateObject("Scripting.Dictionary") a = S.Cells(Rows.Count, 1).End(3).Row b = S.Cells(Rows.Count, 2).End(3).Row Set Ra = S.Range("A2:A" & a) Set Rb = Range("B2:B" & b) For i = 2 To b Dic_Unique(S.Cells(i, 2).Value) = "" Next End Sub '""""""""""""""""""""""""""""""""""""""""""" Sub ExtractB() Item_Unique S.Range("K2").CurrentRegion.Offset(1).ClearContents If Dic_Unique.Count Then For Each Ky In Dic_Unique.keys Bol = IsError(Application.Match(Ky, Ra, 0)) If Bol Then Dic(Ky) = 1 Else Dic(Ky) = Application.CountIf(Rb, Ky) - 1 End If Next Ky End If If Dic.Count Then m = 2 For Each Ky In Dic.keys If Dic(Ky) <> 0 Then S.Range("K" & m).Resize(Dic(Ky)) = Ky m = m + Dic(Ky) End If Next t = S.Range("k2").CurrentRegion.Rows.Count If t > 1 Then S.Range("L2") = t - 1 S.Range("J2").Resize(t - 1).Value = _ Evaluate("Row(1:" & t - 1 & ")") End If End If Set S = Nothing Set Ra = Nothing: Set Rb = Nothing Set Dic_Unique = Nothing Set Dic = Nothing End Sub الملف مرفق
Alla_20_4.xlsm

<رب هذا الملف
Sub each_row_to_Its_sheet() Dim lr, i, x Dim sh As Worksheet Sheets("jan").Range("a2").CurrentRegion.Offset(1).ClearContents Sheets("Feb").Range("a2").CurrentRegion.Offset(1).ClearContents Sheets("Mar").Range("a2").CurrentRegion.Offset(1).ClearContents With Sheets("Legal") lr = .Cells(Rows.Count, 1).End(3).Row For i = 3 To lr If Not IsDate(.Cells(i, 2)) Then GoTo next_i Select Case Month(.Cells(i, 2)) Case 1: Set sh = Sheets("jan") Case 2: Set sh = Sheets("Feb") Case 3: Set sh = Sheets("Mar") Case Else: GoTo next_i End Select x = sh.Cells(Rows.Count, 1).End(3).Row + 1 sh.Cells(x, 1).Resize(, 5).Value = _ .Cells(i, 1).Resize(, 5).Value next_i: Next i End With End Sub الملف مرفق
Naser.xlsm

الكود المطلوب
Private Sub TextBox27_Change() Dim bol As Boolean If TextBox27.Value <> "" Then ListBox1.Visible = True Else ListBox1.Visible = False End If Dim x As Worksheet Dim c As Range ListBox1.Clear k = 0 For i = 1 To 26 Controls("TextBox" & i).Text = "" Next i If TextBox27 = "" Then Exit Sub bol = Me.OptionButton1 = True If bol Then For Each x In ThisWorkbook.Worksheets SS = x.Cells(Rows.Count, 2).End(xlUp).Row For Each c In x.Range("B2:B" & SS) If Trim(c) Like TextBox27 & "*" Then ListBox1.AddItem ListBox1.List(k, 0) = x.Cells(c.Row, 2) ListBox1.List(k, 1) = c.Worksheet.Name ListBox1.List(k, 2) = c.Row ListBox1.List(k, 3) = x.Name k = k + 1 End If Next c Next x Else For Each x In ThisWorkbook.Worksheets SS = x.Cells(Rows.Count, 2).End(xlUp).Row For Each c In x.Range("B2:B" & SS) If Trim(c) Like "*" & TextBox27 & "*" Then ListBox1.AddItem ListBox1.List(k, 0) = x.Cells(c.Row, 2) ListBox1.List(k, 1) = c.Worksheet.Name ListBox1.List(k, 2) = c.Row ListBox1.List(k, 3) = x.Name k = k + 1 End If Next c Next x End If End Sub الملف مرفق
Allaq_User.xlsm

جرب هذا الملف
الكود
Option Explicit Function Elctric(Sm, n1, n2, n3, n4, n5, n6, n7) Dim x# If Sm <= 0 Then Elctric = 9 Exit Function End If Select Case Sm Case Is < 50: x = (50 - Sm) * n1 Case Is < 100: x = 50 * n1 + (Sm - 50) * n2 Case Is < 200: x = 50 * n1 + 50 * n2 + (Sm - 100) * n3 Case Is < 350: x = 50 * n1 + 50 * n2 + 100 * n3 + _ (Sm - 200) * n4 Case Is < 650: x = 50 * n1 + 50 * n2 + 100 * n3 + _ 200 * n4 + (Sm - 350) * n5 Case Is < 1000: x = 50 * n1 + 50 * n2 + 100 * n3 + _ 200 * n4 + 350 * n5 + (Sm - 650) * n6 Case Else: x = 50 * n1 + 50 * n2 + 100 * n3 + _ 200 * n4 + 350 * n5 + 650 * n6 + (Sm - 1000) * n7 End Select Elctric = x End Function الملف مرفق
Electric.xlsm

ربما هذا الكود
Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim Large_RG As Range Dim Unique_RG As Range Dim Empty_String$, Other__String$ Dim Option_string$ Dim Position% Const m = 2 Empty_String = "": Other__String$ = "Hirassa" Set Large_RG = Range("Q9:Y300") Set Unique_RG = Range("G3") Dim q%, r%, S%, t%, u%, v%, W%, x%, y% q = 17: r = 18: S = 19: t = 20 u = 21: v = 22: W = 23: x = 24: y = 25 Application.EnableEvents = False If Not Intersect(Target, Unique_RG) Is Nothing _ And Target.Cells.Count = 1 Then Range("D8") = Other__String End If If Not Intersect(Target, Large_RG) Is Nothing _ And Target.Cells.Count = 1 Then Select Case Target.Column Case q: Option_string = Empty_String: Position = q - 2 * m Case r: Option_string = Empty_String: Position = r - 3 * m Case S: Option_string = Empty_String: Position = S - 4 * m Case t: Option_string = Empty_String: Position = t - 5 * m Case u: Option_string = Empty_String: Position = u - 6 * m Case v: Option_string = Empty_String: Position = v - 7 * m Case W: Option_string = Empty_String: Position = W - 8 * m Case x: Option_string = Empty_String: Position = x - 9 * m Case y: Option_string = Empty_String: Position = y - 10 * m End Select If Target = "a" Then Target.Offset(, Position) = Empty_String End If End If Application.EnableEvents = True End Sub الملف
 
Joe_code.xlsm

جرب هذا الملف
Data_Val_Jo.xlsm

تم التعذيل على الماكروات
Option Explicit Private sh As Worksheet Private Ro%, Col%, i% Private Arr_text(), Arr_Num() Private F As Range, itm, K% '++++++++++++++++++++++++++++++++++ Private Sub Fnd_change() Debut Dim R1%, R2% Me.ListBox1.RowSource = "" If Fnd = "" Then Exit Sub For Each itm In Arr_text Me.Controls(itm) = "" Next Set F = sh.Range("A1:A" & Ro).Find(Me.Fnd & "*", Lookat:=2) If Not F Is Nothing Then R1 = F.Row: R2 = R1 Do With Me.ListBox1 .AddItem For i = 0 To .ColumnCount - 1 .List(.ListCount - 1, i) = sh.Cells(R2, 1).Offset(, i) Next Set F = sh.Range("A1:A" & Ro).FindNext(F) R2 = F.Row If R2 = R1 Then Exit Do End With Loop End If End Sub '+++++++++++++++++++++++++++++++ Private Sub ListBox1_Click() Debut Dim t% If ListBox1.ListCount = 0 Then Exit Sub If ListBox1.ListIndex = -1 Then Exit Sub t = Me.ListBox1.ListIndex Set F = sh.Range("A1:A" & Ro).Find(Me.ListBox1.List(t, 0), Lookat:=1) If F Is Nothing Then Exit Sub K = F.Row If K <> 1 Then For i = 0 To 6 Me.Controls(Arr_text(i)).Text = _ sh.Cells(K, Arr_Num(i)) Next End If End Sub '+++++++++++++++++++++++++++++++++++++ Sub Debut() Set sh = Sheets("Main") Ro = sh.Cells(Rows.Count, 1).End(3).Row Col = 7 Arr_text = Array("Fat", "Dat", "Cahier", "Prod", _ "Qty", "Price", "Total") Arr_Num = Array(1, 2, 3, 4, 5, 6, 7) sh.Cells(1, 1).Resize(Ro, 7).Interior.ColorIndex = xlNone End Sub '+++++++++++++++++++++++++++++++++++++++ Private Sub Cmd_del_Click() Debut Dim t%, st If Me.ListBox1.ListCount = 0 Or Me.Fnd = "" Then Exit Sub t = Me.ListBox1.ListIndex st = Me.ListBox1.List(t, 0) Set F = sh.Range("A1:A" & Ro).Find(st, Lookat:=1) If F Is Nothing Then Exit Sub K = F.Row If K <> 1 Then sh.Cells(K, 1).Resize(, 7).Delete Me.ListBox1.RemoveItem (t) ListBox1.ListIndex = -1 For i = 0 To 6 Me.Controls(Arr_text(i)) = "" Next MsgBox "the Item " & """" & st & """" & Chr(10) & _ "with address " & """" & sh.Cells(K, 1).Resize(, 7).Address(0, 0) _ & """" & " Is Deleted", 64 Fnd = "" End If End Sub '+++++++++++++++++++++++++++++++++++++++ Private Sub UserForm_Initialize() Debut Me.ListBox1.RowSource = _ sh.Range("A2").Resize(Ro, Col).Address End Sub الملف من جديد
My_ListBox_1.xlsm

جرب هذا الملف
1-تسمية اوراق العمل دائماً باللغة الاجنبية وأرفض من الآن وصاعداً اي ملف اسماء صفحاته باللغة العربية لما يسبب هذا الشيء من اضطراب في الكود اضافة الى صعوبة نسخة ولصقة لظهور احرف غريبة فية (عند البعض طبعاً)
  مع احترامي الشديد للغتنا العربية (لغة القرآن الكريم) لكنها لا تصلح لوضع اكواد الـــ VBA (نسبة الأحطاء 70% حسب الدّراسات)
2- من المفروض اضافة القليل من البيانات في الأوراق العمل ولا تتكل على من يريد المساعدة للقيام بذلك
3- تم وضع بعض المعادلات التي تساعد في ادراج النتائج (دون ظهور الأصفار)
4- الصف رقم 6 في الاوراق Bay  و  Inport يجب ان يبقى فارغاً
الكود
Option Explicit Sub From_Sheets_To_MaG() Dim Inp As Worksheet, Bay As Worksheet Dim Mag As Worksheet Dim Sh As Worksheet Dim L_Mag%, Max_ro%, col%, k%, ro% Dim Fnd As Range, Wat As Range Dim Old_val Set Inp = Sheets("Inport") Set Bay = Sheets("Bay") Set Mag = Sheets("Magazine") L_Mag = Mag.Cells(Rows.Count, 1).End(3).Row Set Fnd = Mag.Range("A1:A" & L_Mag) If Not (ActiveSheet.Name = "Inport" Or _ ActiveSheet.Name = "Bay") Then Exit Sub Set Sh = ActiveSheet Select Case Sh.Name Case "Bay": col = 6 Case "Inport": col = 5 Case Else: Exit Sub End Select Max_ro = Application.Max(Sh.Range("B6:B68")) + 6 For k = 7 To Max_ro Set Wat = Fnd.Find(Sh.Range("E" & k), lookat:=1) If Not Wat Is Nothing Then ro = Wat.Row Old_val = Val(Mag.Cells(ro, 3)) Mag.Cells(ro, 7) = Old_val Mag.Cells(ro, col) = Val(Sh.Range("H" & k)) Mag.Cells(ro, 3) = _ Old_val + Val(Mag.Cells(ro, 5)) - Val(Mag.Cells(ro, 6)) End If Next End Sub الملف مرفق
Hasan_B.xlsm