سليم حاصبيا

تم التعديل Option Explicit Sub FInd_Please() Dim S As Worksheet, T As Worksheet Dim LR%, x%, y%, n%, m% Dim F_rg As Range, Search_rg As Range Dim Find_wath Dim Ad1$, Ad2$ With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Set S = Sheets("Source") Set T = Sheets("Target") With T.Range("C8").CurrentRegion .ClearContents .Interior.ColorIndex = xlNone End With x = S.Range("A8").CurrentRegion.Rows.Count y = S.Range("A8").CurrentRegion.Columns.Count If T.Range("c2") = vbNullString Then GoTo Exit_Sub Select Case T.Range("C2") Case "مسلسل": n = 1 Case "اسم التلميذ": n = 2 Case "الرقم القومي": n = 3 Case "المحافظة": n = 4 Case "تاريخ الميلاد": n = 5 Case Else: GoTo Exit_Sub End Select Select Case T.Range("B2") Case Is <> "" Find_wath = T.Range("B2") Case Else Find_wath = "*" End Select If Find_wath = "*" Then T.Range("A9").Resize(x, y).Value = _ S.Range("A8").Resize(x, y).Value Else Set F_rg = S.Range("A7").CurrentRegion.Columns(n) Set Search_rg = F_rg.Find(Find_wath, LookIn:=xlValues, lookat:=1) If Search_rg Is Nothing Then MsgBox "Check Up the Cell B2" GoTo Exit_Sub End If Ad1 = Search_rg.Address: Ad2 = Ad1 m = 9 Do T.Range("A" & m).Resize(, y).Value = _ S.Range("A" & Search_rg.Row).Resize(, y).Value m = m + 1 Set Search_rg = F_rg.FindNext(Search_rg) Ad2 = Search_rg.Address If Ad1 = Ad2 Then Exit Do Loop T.Range("A9").Resize(m - 9, 12) _ .Interior.ColorIndex = 19 End If Exit_Sub: With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub fuzy_data_new.xlsm

هذا الماكرو Option Explicit Sub copy_by_choise() Dim sh As Worksheet Dim Rg As Range Dim f_rg As Range Dim x%, n% Set sh = Sheets("Sheet1") sh.Range("E4").CurrentRegion.ClearContents Set Rg = sh.Range("N1").CurrentRegion x = Rg.Rows.Count If x = 1 Then Exit Sub Set f_rg = Rg.Rows(1).Find(sh.Range("F2"), lookat:=1) If f_rg Is Nothing Then Exit Sub Set Rg = Rg.Offset(1).Resize(x - 1) n = f_rg.Column - 12 sh.Range("E4").Resize(Rg.Rows.Count).Value = _ Rg.Columns(n).Value End Sub

تم معالجة الأمر 1- لبس المرة الأولى التي أقول فيها: تسمية الشيتات باللغة الأجنبية و فصل الجدول عن باقي الخلايا بصفوف فارغة و عدم ادراج خلايا مدمجة داخل الجدول / ولا حياة لمن تنادي / (تم اضافة صفوف فارغة لهذا الأمر لآخر مرّة لن امد يد المساعدة بعد الآن بدون هذه الأشياء) 2- اذا كات الخلية B2 فارغة تحصل على كل البيانات Option Explicit Sub FInd_Please() Dim S As Worksheet, T As Worksheet Dim LR As Long, Nam As String Dim F_rg As Range, d% Dim Find_wath Dim Search_rg As Range Dim x%, y%, n% With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Set S = Sheets("Source") Set T = Sheets("Target") T.Range("C8").CurrentRegion.ClearContents x = S.Range("A8").CurrentRegion.Rows.Count y = S.Range("A8").CurrentRegion.Columns.Count If T.Range("c2") = vbNullString Then GoTo Exit_Sub Select Case T.Range("C2") Case "مسلسل": n = 1 Case "اسم التلميذ": n = 2 Case "الرقم القومي": n = 3 Case "المحافظة": n = 4 Case "تاريخ الميلاد": n = 5 Case Else: GoTo Exit_Sub End Select Select Case T.Range("B2") Case Is <> "" Find_wath = T.Range("B2") Case Else Find_wath = "*" End Select If Find_wath = "*" Then T.Range("A9").Resize(x, y).Value = _ S.Range("A8").Resize(x, y).Value Else Set F_rg = S.Range("A7").CurrentRegion.Columns(n) Set Search_rg = F_rg.Find(Find_wath, lookat:=1) If Search_rg Is Nothing Then MsgBox "Check Up the Cell B2" GoTo Exit_Sub End If T.Range("A9").Resize(, y).Value = _ S.Range("A" & Search_rg.Row).Resize(, y).Value End If Exit_Sub: With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub fuzy_data.xlsm

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

لا افهم اين الحطأ

تم معالجة الأمر mohd.xlsx

أين تجد البند 3 في هذه الصزرة؟؟؟

املا الكومبوبوكسات(اليوزر) في هذا الملف ثم اضغظ الزر "تعديل" اليس هذا ما تريده ؟؟؟؟ abdusayed.xlsm

انا لا أعمل في مجال اليوزر فورم( ولا أطيقه اصلاُ) لكن أعرف ان الليست بوكس لا يمكن ان يعبىء كثر من 10 أعمدة بواسطة AddItem للنغلب على هذه المشكلة يمكن استعمال الـــ Array كما في هذا الكود Private Sub CommandButton1_Click() '++++++++++++++++++++++ Dim arr() As Variant Dim i As Long With Me.ListBox1 ReDim arr(1 To 1, 1 To .ColumnCount) For i = LBound(arr, 2) To UBound(arr, 2) arr(1, i) = Me.Controls("TextBox" & i).Value Next i .List = arr() End With End Sub

اكتب الرقم فقط (4 Characters) الكود اللازم Option Explicit Private Sub TextBox1_Change() Dim Ws As Worksheet Dim Lr% Dim My_val Dim F_rg As Range Set Ws = Sheets("Sheet_1") Lr = Ws.Cells(Rows.Count, 1).End(3).Row Ws.Range("A3:N" & Lr).Interior.ColorIndex = xlNone If Len(TextBox1) > 8 Then TextBox1 = "": Exit Sub If Len(TextBox1) = 4 Then My_val = "CIN-" & TextBox1.Text TextBox1.Text = My_val Set F_rg = Ws.Range("A2:A" & Lr).Find(My_val, lookat:=1) '+++++++++++++++++++++++++++ If F_rg Is Nothing Then Ws.Range("A3").Select MsgBox "I Can't Find The Value:" & Chr(10) & Chr(10) & _ """" & My_val & """" Else With Ws.Range("A" & F_rg.Row) .Select .Resize(, 14).Interior.ColorIndex = 35 End With End If End If End Sub الكلف مرفق abou_kasem_text_box.xlsm

لعل هذا ما ريده mohd322.xlsx

لا أعلم اذا كان هذا ماتريد Jabalawi.xlsx

حيث انك عضو جديد يمكن تجربة هذا الملف لكن في المرة القادمة الملف ضروري monney.xlsm

Try This file adel1.xlsx

تم معالجة الأمر Sub Sum_With_Blank() Dim LR%, t%, m%, k% With Sheets("Sheet2") LR = .Range("j" & Rows.Count).End(xlUp).Row k = 5 For t = 5 To LR + 2 If Application.CountA(.Cells(t, "J") _ .Resize(, 3)) = 0 Then With .Cells(t, "J").Offset(1) .Formula = "=SUM(J" & k & ":L" & t & ")" .Value = IIf(.Value = 0, _ vbNullString, .Value) .Value = .Value End With t = t + 2 k = t + 1 End If Next End With End Sub Ahnad_Sh.xlsm

1-كالعادة تسمية الورقة باللغة الأجنبية 2- اكنب في Texbox ما تـريد 3-اضغط أحد المفاتيح Enter , Tab , Any arrows Code Option Explicit Private Sub TextBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) Dim Ws As Worksheet Dim Lr% Dim My_val Dim F_rg As Range Set Ws = Sheets("Sheet_1") Lr = Ws.Cells(Rows.Count, 1).End(3).Row Ws.Range("A3:N" & Lr).Interior.ColorIndex = xlNone Select Case KeyCode Case 37 To 40, 13 My_val = TextBox1.Text Case Else Exit Sub End Select Set F_rg = Ws.Range("A2:A" & Lr).Find(My_val, lookat:=1) If F_rg Is Nothing Then Ws.Range("A3").Select Else With Ws.Range("A" & F_rg.Row) .Select .Resize(, 14).Interior.ColorIndex = 35 End With End If End Sub Flle Icluded abou_kasem.xlsm

Try this File Mhoud_1980.xlsx

هذا الكود Option Explicit Sub test1() Dim sh As Worksheet Dim Ro As Long Dim i%, t% Set sh = Sheets("test") With sh Ro = .Range("G" & Rows.Count).End(3).Row .Range("B31:C39").ClearContents If Ro < 51 Then Exit Sub t = 31 For i = 51 To Ro If UCase(.Range("G" & i)) = "YES" Then Range("B" & t).Value = _ Range("B" & i).Value t = t + 1 If t >= 40 Then Exit For End If Next i End With End Sub

لمعرفة ماذا تعني End(4) جرب هذا الكود Sub What_is_End4() MsgBox Sheets("Sheet1").Range("A1", Range("A1").End(4)).Address End Sub بالنسية الصفحة الثّانية هذا الكود Option Explicit Sub sum_Of_JL_Sh_2() Dim LR%, t%, m% With Sheets("Sheet2") LR = .Range("j" & Rows.Count).End(xlUp).Row For t = 5 To LR .Cells(t, "j") = _ IIf(Application.CountA(.Cells(t, "J") _ .Resize(, 3)) = 1, vbNullString, .Cells(t, "j")) Next m = .Range("j5", Range("j5").End(4)).Rows.Count t = 5 Do While t < LR With .Cells(t, "J").Resize(m, 3) .Cells(m, 1).Offset(2) = _ Application.sum(.Value) End With t = t + m + 3 Loop End With End Sub الملف مرفق My_test.xlsm

يالنسية للكود الثّاني صفحة Sheet1 العامودين K & L Sub Multi_J_K() Dim LR%, t% With Sheets("Sheet1") LR = .Range("j" & Rows.Count).End(xlUp).Row For t = 1 To LR .Cells(t, "j") = _ IIf(Application.CountA(.Cells(t, "J") _ .Resize(, 3)) = 1, vbNullString, .Cells(t, "j")) Next m = .Range("j1", Range("j1").End(4)).Rows.Count t = 1 Do Until t > LR Cells(t + m + 1, "J") = _ Application.Sum(Cells(t, "J").Resize(m, 3)) t = t + m + 3 Loop End With End Sub

تم معالجة الأمر 1- الـشيت Salim هي مثال لما يفوم به الماكرو Do it ( الـشيت Salim هي نسخة طبق الأصل عن الشيت 1999 ) للتجربة فقط تم ادراج هذه الصفحة حفاظاً على البيانات الاساسية لأنه في حال كان المطلوب غير ذلك لا تتأثر البيانات الاساسية في الشيت 1999 (لا يمكن التراجع عما يفعله اي ماكرو بواسطة الأمر Undo ) الكود Option Explicit Dim ro As Long Dim i As Long Sub Do_it() Remove_Minus Remove_Similar End Sub '++++++++++++++++++++++ Sub Remove_Minus() With Sheets("salim") ro = .Cells(Rows.Count, "M").End(3).Row For i = 2 To ro If IsNumeric(Cells(i, "M")) Then Cells(i, "M") = Abs(Cells(i, "M")) End If Next End With End Sub '++++++++++++++++++++++++ Sub Remove_Similar() Sheets("salim").Range("A1").CurrentRegion.RemoveDuplicates _ Columns:=Array(4, 5, 11, 13), Header:=1 End Sub الملف مرفق Remove_Dup.xlsm

اين تجد التكرار في الصورة اذا كان العددين بنفس القيمة لكن واحد سالب والآخر موجب (هذا لا يعني انهما متساوين) لذلك تركت انا العامود 13 (M) بدون حذف التكرارات منه

جرب هذا الكود Sub Remove_Similar() ActiveSheet.Range("A1").CurrentRegion.RemoveDuplicates _ Columns:=Array(4, 5, 11), Header:=1 End Sub

الكود بشكل محتصر أكثر Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.DisplayFormulaBar = _ Intersect(Target, Range("b2:b10")) Is Nothing End Sub

جرب هذا الكود (مع تعديله الى النطاق الذي نريده) Option Explicit Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.ScreenUpdating = False Application.EnableEvents = False If Not Intersect(Target, Range("A2:A10")) Is Nothing Then Application.DisplayFormulaBar = False Else Application.DisplayFormulaBar = True End If Application.EnableEvents = True Application.ScreenUpdating = True End Sub