أبو حنــــين

السلام عليكم اولا قم بتحويل المعادلة الموجودة في الخلية A1 بهذا الشكل =IFERROR(VLOOKUP(Sel;M4:N8;2;0);"") ثانيا غير الكود السابق بهذا الكود Private Sub Worksheet_Change(ByVal Target As Range) If Range("A1") = 0 Then GoTo 100 If Range("A1") = "" Then GoTo 200 If Target.Address = Range("A2").Address Then _ Range("A3:K21").AutoFilter Field:=1, Criteria1:="=" & Range("A1") Exit Sub 100 Range("A3:K21").AutoFilter Field:=1, Criteria1:="<>" & "" Exit Sub 200 Range("A3:K21").AutoFilter End Sub ============== عندما تريد رؤية كل البيانات بما فيها الصفوف الفارغة إمسح الخلية التي تختارمنها الشركات ( A2 ) التي اسمها Sel

السلام عليكم كود يشمل رقم الصف و العمود و الحرف الذي ينتمي اليه العمود في آن واحد Sub MMMM() Dim CLO As Integer, NR As Integer, NC As String NC = Split(ActiveCell.Address, "$")(1) NR = Split(ActiveCell.Address, "$")(2) COL = Range(Split(ActiveCell.Address, "$")(1) & "1").Column MsgBox "العمود : " & COL & Chr(13) & NC & " : الحرف" & Chr(13) & "الصف : " & NR, vbInformation + vbMsgBoxRight, "" End Sub

السلام عليكم يصبح شكل الكود كالتالي Private Sub CommandButton1_Click() Application.ScreenUpdating = False ActiveSheet.UsedRange.Rows.Select Range("L2:L" & Cells(Rows.Count, 12).End(3).Row).ClearContents Dim Rng, nCells, c, MyObject As Object, LR As Long LR = ActiveSheet.UsedRange.Rows.Count Set MyObject = CreateObject("Scripting.Dictionary") Rng = Selection.Value For Each c In Rng If c <> "" Then MyObject(c) = c Next c nCells = MyObject.Keys Range("l2").Resize(MyObject.Count, 1) = Application.Transpose(nCells) Range("l2").Select Application.ScreenUpdating = True End Sub

مرحبا تقريا نفس الكود الذي وضعه اخي ياسر Sub ColorRange() Application.ScreenUpdating = False Dim c1 As Range, c2 As Range Range("b3:i16").Interior.ColorIndex = xlNone: Range("b3:i16").Font.ColorIndex = 1 For Each c1 In Range("b3:i16"): For Each c2 In Range("b3:i16") If Val(c1.Value) + Val(c2.Value) = Range("a2").Value Then x = Int(Rnd * 55) c1.Interior.ColorIndex = Val(x): c2.Interior.ColorIndex = Val(x) End If If c1.Value = Range("a2").Value Then c1.Font.ColorIndex = 46 If c2.Value = Range("a2").Value Then c2.Font.ColorIndex = 46 Next Next Application.ScreenUpdating = True End Sub

جزاك الله خيرا أخي ياسر شرح كامل للكود من ما لا يدع اي مجال للشبهة في اي سطر من الكود .

السلام عليكم قم فقط بتغيير الرقم 19 الى الرقم 6 في زر الحفظ و في الجزئية التالية و الرقم 6 يعني إلزامية ملأ 6 خاننات الأولى : المحامي - الدعاوي - الضربة - الايصال - عدد - رسم With SH Last = .Cells(Rows.Count, "A").End(xlUp).Row + 1 ' هذا هو الرقم المعني بالتغيير من 19 الى 6 For x = 1 To 19 If Me.Controls("T" & x) = "" Then MsgBox "هناك بيانات غير مكتملة", vbExclamation + vbMsgBoxRight, "خطأ" Me.Controls("T" & x).SetFocus Exit Sub End If Next

أخي الزباري جزاك الله خيرا

مرحبا تم عمل المطلوب ترحيل 5.rar

مرحبا هل بهذه الطريقة فلتر جدول بالكود.rar

تم التعديل ترحيل 4.rar

مرحبا هذا الكود يقوم بالتوزيع Sub dddd() Application.ScreenUpdating = False Dim Rng As Range, cel As Range, i As Integer, My_SHYTES As New Collection Set Rng = Range("M4:M" & Cells(Rows.Count, 13).End(xlUp).Row) On Error Resume Next For Each cel In Rng My_SHYTES.Add cel.Value, CStr(cel.Value) ' Next cel For i = 1 To My_SHYTES.Count Sheets.Add After:=Sheets(Sheets.Count) Set SH = ActiveSheet With SH .Name = My_SHYTES(i) Sheets("Salary Sheet").Range("A3:AL3").Copy .Range("A1").PasteSpecial xlPasteValues .Range("A1:X1").Borders.Value = 1 .Range("A1:AL1").Font.Bold = True .Range("A1:AL1").Interior.ColorIndex = 43 .Columns("A:AL").EntireColumn.AutoFit End With Next i 'ScOpy End Sub و هذا الكود يقوم بالنسخ Sub ScOpy() Application.ScreenUpdating = False Dim i As Integer, SH As Worksheet, HS As Worksheet, Lr As Integer, iLr As Integer Set SH = Sheets("Salary Sheet") With SH Lr = .Cells(Rows.Count, 1).End(xlUp).Row For i = 4 To Lr 'Sheets.Count For Each HS In Sheets If HS.Name = SH.Cells(i, 13) Then iLr = HS.Cells(Rows.Count, 1).End(xlUp).Row + 1 SH.Range("A" & i).Resize(, 38).Copy HS.Range("A" & iLr).PasteSpecial (xlPasteValues) HS.Range("A1:AL" & iLr).Borders.Value = 1 HS.Columns("A:AL").EntireColumn.AutoFit End If Next Next End With Application.ScreenUpdating = True Application.CutCopyMode = False Sheets("Salary Sheet").Select End Sub

السلام عليكم جرب المرفق Salary Sheet.rar

مرحبا هل بهذه الطريقة ترحيل 3.rar

السلام عليكم جرب المرفق 2ترحيل.rar

السلام عليكم اخي ياسر العربي : جزاك الله خيرا

لماذا لا تستعمل الدالة SUMPRODUCT =SUMPRODUCT(--(A3:A5>100);--(A3:A5<400);--(B3:B5)) او الدالة SUMIFS =SUMIFS(B3:B6;A3:A6;">100";A3:A6;"<400")

غير A الى F غير B الى G

مرحبا توجد أكثر من طريقة ' طريقة 1 Dim Ctrl As Control For Each Ctrl In Me.Controls If TypeOf Ctrl Is MSForms.TextBox Then Ctrl = Format(Ctrl, "#,##0") Next Ctrl '"****************************************************************************** ' طريقة 2 For i = 1 To 20 Me.Controls("TextBox" & i) = Format(Me.Controls("TextBox" & i), "#,##0") Next

مرحبا جرب هذا الكود Sub iDel() Application.ScreenUpdating = False For R = Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1 If WorksheetFunction.CountIf(Range("A2:A" & R), Cells(R, 1).Value) > 1 Then ' Range("A" & R & ":B" & R).ClearContents Range("A" & R & ":B" & R).Delete Shift:=xlUp End If Next Application.ScreenUpdating = True End Sub

نقل بيانات معينة.rar Sans titre.rar في سؤالك الأول لم توضح أي شرط

السلام عليكم هذا ايضا كود آخر يقوم بنفس المهمة Sub iCOPY() Application.ScreenUpdating = False Dim Rng As Range, _ shs As Worksheet, shd As Worksheet, _ LastS As Integer, LastD As Integer Set shs = Sheets("اعتمادية3"): Set shd = Sheets("تسهيل مهمة") LastS = shs.Cells(Rows.Count, 2).End(xlUp).Row For i = 2 To LastS Set Rng = Union(shs.Range("B2:B" & i), _ shs.Range("D2:D" & i), shs.Range("E2:E" & i), shs.Range("H2:H" & i)) Rng.Copy Next shd.Range("I" & shd.Cells(Rows.Count, 9).End(xlUp).Row + 1).PasteSpecial xlPasteValues Application.ScreenUpdating = True Application.CutCopyMode = False MsgBox "Êã äÞá " & Rng.Rows.Count & " ÕÝæÝ Çáì æÑÞÉ ÊÓåá ãåãÉ", vbInformation + vbMsgBoxRight, "ÊÑÍíá" End Sub

مرحبا اخي حسين جرب المرفق Boo2.rar

السلام عليكم لإثراء الموضوع يمكن ان نستعمل Sub Test() MsgBox Split(ActiveCell.Address, "$")(1) End Sub

مرحبا تم عمل اللازم 4استعلام.rar

السلام عليكم تمت الاجابة