ابا اسماعيل

تفضل اخي الفضل Private Sub TextBox1_Change() If Val(TextBox1.Value) > 0 Then TextBox1.BackColor = RGB(255, 0, 0) ' ÇáÃÍãÑ: RGB(255, 0, 0) Else TextBox1.BackColor = RGB(255, 255, 255) ' ÇáÃÈíÖ: RGB(255, 255, 255) End If End Sub

Private Sub TextBox1_Change() If Val(TextBox1.Value) > 0 Then TextBox1.ForeColor = RGB(255, 0, 0) ' الأحمر: RGB(255, 0, 0) Else TextBox1.ForeColor = RGB(0, 0, 0) ' الأسود: RGB(0, 0, 0) End If End Sub ^ vdf

جرب هذا الكود Private Sub CommandButton1_Click() Dim WB As Workbook Dim SH As Worksheet Dim SH2 As Worksheet Dim SH3 As Worksheet Dim SH4 As Worksheet Dim LR As Long, LR1 As Long, LR2 As Long, LR3 As Long, LR4 As Long, LR5 As Long, LR6 As Long Dim i As Long, Q As Long, U As Long Dim X As Long, N As Long, T As Long Dim DataArray() As Variant ' مصفوفة لتخزين البيانات مؤقتًا Set WB = ThisWorkbook Set SH = WB.Sheets("CUT") Set SH2 = WB.Sheets("POLISH") Set SH3 = WB.Sheets("AR_ST") Set SH4 = WB.Sheets("AR_PAID") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ' تنظيف ورقة SH3 SH3.Range("B4:M" & SH3.Rows.Count).ClearContents ' حساب آخر صفوف البيانات في كل ورقة LR = SH.Cells(SH.Rows.Count, "D").End(xlUp).Row LR1 = SH3.Cells(SH3.Rows.Count, "B").End(xlUp).Row + 1 LR2 = SH2.Cells(SH2.Rows.Count, "E").End(xlUp).Row LR5 = SH4.Cells(SH4.Rows.Count, "B").End(xlUp).Row ' تخزين البيانات في مصفوفة ReDim DataArray(1 To LR - 3, 1 To 6) X = 1 For i = 4 To LR If SH3.Cells(2, "B") = SH.Cells(i, "D") And SH.Cells(i, "AC") <> "0" Then DataArray(X, 1) = SH.Cells(i, "O") DataArray(X, 2) = SH.Cells(i, "F") DataArray(X, 3) = SH.Cells(i, "G") DataArray(X, 4) = SH.Cells(i, "P") DataArray(X, 5) = SH.Cells(i, "AC") X = X + 1 End If Next i ' كتابة البيانات في ورقة SH3 SH3.Range("B" & LR1).Resize(X - 1, 5).Value = DataArray N = LR1 + X - 1 ' تخزين البيانات من SH2 في مصفوفة ReDim DataArray(1 To LR2 - 3, 1 To 6) X = 1 For Q = 4 To LR2 If SH3.Cells(2, "B") = SH2.Cells(Q, "E") Then DataArray(X, 1) = SH2.Cells(Q, "B") DataArray(X, 2) = SH2.Cells(Q, "C") DataArray(X, 3) = SH2.Cells(Q, "D") DataArray(X, 4) = SH2.Cells(Q, "G") DataArray(X, 5) = SH2.Cells(Q, "L") DataArray(X, 6) = SH2.Cells(Q, "P") X = X + 1 End If Next Q ' كتابة البيانات في ورقة SH3 SH3.Range("B" & N).Resize(X - 1, 6).Value = DataArray T = N + X - 1 ' تخزين البيانات من SH4 في مصفوفة ReDim DataArray(1 To LR5 - 3, 1 To 2) X = 1 For U = 4 To LR5 If SH3.Cells(2, "B") = SH4.Cells(U, "C") Then DataArray(X, 1) = SH4.Cells(U, "B") DataArray(X, 2) = SH4.Cells(U, "F") X = X + 1 End If Next U ' كتابة البيانات في ورقة SH3 SH3.Range("B" & T).Resize(X - 1, 2).Value = DataArray Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub

جريب هذا الكود Sub FasterMacro() Dim wsSource As Worksheet Dim wsCriteria As Worksheet Dim wsExtract As Worksheet Dim sourceRange As Range Dim criteriaRange As Range Dim extractRange As Range ' تحديد ورقة المصدر Set wsSource = ThisWorkbook.Sheets("Sheet1") ' قم بتغيير "Sheet1" إلى اسم ورقتك ' تحديد ورقة المعايير Set wsCriteria = ThisWorkbook.Sheets("ÇáÊÓÌíá (2)") ' قم بتغيير اسم الورقة إذا لزم الأمر ' تحديد ورقة الاستخراج Set wsExtract = ThisWorkbook.Sheets("ÇáÊÓÌíá (2)") ' قم بتغيير اسم الورقة إذا لزم الأمر ' تحديد نطاق البيانات المصدر Set sourceRange = wsSource.Range("AM:BD") ' تحديد نطاق المعايير Set criteriaRange = wsCriteria.Range("'Criteria'") ' تحديد نطاق الاستخراج Set extractRange = wsExtract.Range("'Extract'") ' تطبيق تصفية متقدمة sourceRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=criteriaRange, CopyToRange:=extractRange, Unique:=False ' تحديد نطاق آخر (يمكن تعديله وفقًا لاحتياجاتك) wsSource.Range("DC3:DT3").Select End Sub

Private Sub CommandButton1_Click() ' إلغاء عملية التصفية إذا كانت مفعلة If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False End If ' عرض نافذة الطباعة Application.Dialogs(xlDialogPrint).Show End Sub

بهذا الشكل، عندما تقوم باختيار صنف من الكمبوبوكس وتضغط على زر الطباعة، سيتم تنفيذ عملية الطباعة للصنف المختار وسيتم إلغاء عملية التصفية Private Sub CommandButton2_Click() With Worksheets("التكويد").Range("A1:T1") ' إلغاء الفلتر إذا كان مفعلاً If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False End If If Me.ComboBox1.Text = "" Then Exit Sub ' تنفيذ عملية التصفية .AutoFilter Field:=3, Criteria1:=Me.ComboBox1.Text End With ' استدعاء الطباعة Call CommandButton1_Click ' إلغاء الفلتر بعد الطباعة If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False End If End Sub

بعد اذن الاخ أبوأحـمـد جرب هذا الكود سيقوم بالتحقق من وجود القيم المكررة في الأعمدة A و B و C وسيقوم بسحب القيم المكررة إلى الأسفل Private Sub RemoveDuplicatesAndFillDown() Dim ws As Worksheet Dim lastRow As Long Dim colRangeA As Range Dim colRangeB As Range Dim colRangeC As Range Dim cell As Range ' تعيين الورقة المستهدفة Set ws = ThisWorkbook.Worksheets("التكويد") ' العثور على آخر صف غير فارغ في العمود C lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row ' تعيين نطاقات الأعمدة A و B و C Set colRangeA = ws.Range("A2:A" & lastRow) Set colRangeB = ws.Range("B2:B" & lastRow) Set colRangeC = ws.Range("C2:C" & lastRow) ' إلغاء تنسيق الخلايا المحددة colRangeA.NumberFormat = "General" colRangeB.NumberFormat = "General" colRangeC.NumberFormat = "General" ' إزالة القيم المكررة وسحب القيم إلى الأسفل في الأعمدة A و B For Each cell In colRangeA If Application.WorksheetFunction.CountIf(colRangeA, cell.Value) > 1 Then cell.Offset(1, 0).Resize(lastRow - cell.Row).Value = cell.Value End If Next cell For Each cell In colRangeB If Application.WorksheetFunction.CountIf(colRangeB, cell.Value) > 1 Then cell.Offset(1, 0).Resize(lastRow - cell.Row).Value = cell.Value End If Next cell For Each cell In colRangeC If Application.WorksheetFunction.CountIf(colRangeC, cell.Value) > 1 Then cell.Offset(1, 0).Resize(lastRow - cell.Row).Value = cell.Value End If Next cell End Sub

بهذا الشكل، سيتم إلغاء عملية تصفية البيانات بعد الطباعة وسيعود الجدول إلى وضعه الطبيعي بدون تصفية. عند طباعة أي صنف آخر Private Sub CommandButton1_Click() ' ... الأكواد الحالية ... ' عرض نافذة الطباعة Application.Dialogs(xlDialogPrint).Show ' إلغاء عملية التصفية بعد الطباعة If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False End If End Sub

تفظل جريب هذا الكود Private Sub Worksheet_Change(ByVal Target As Range) Dim ws As Worksheet Dim cell As Range Set ws = ThisWorkbook.Sheets("Sheet1") If Not Intersect(Target, ws.Columns("A")) Is Nothing Then Application.EnableEvents = False For Each cell In Target If cell.Value <> "" Then Dim charCount As Long charCount = Len(cell.Value) - Len(Replace(cell.Value, " ", "")) Dim fontSize As Long fontSize = 14 - charCount If fontSize < 8 Then fontSize = 8 End If cell.Font.Size = fontSize End If Next cell Application.EnableEvents = True End If End Sub

وعليكم السلام ورحمة الله وبركاته تفضل قوم بتحديث البيانات في العمود اول مرة عند تضع الكود Private Sub Worksheet_Change(ByVal Target As Range) Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim cell As Range Set ws = ThisWorkbook.Sheets("Sheet1") ' If Not Intersect(Target, ws.Columns("A")) Is Nothing Then Application.EnableEvents = False ص For Each cell In Target If cell.Value <> "" Then Dim wordCount As Long wordCount = Len(cell.Value) - Len(Replace(cell.Value, " ", "")) + 1 If wordCount = 1 Then cell.Font.Size = 14 ElseIf wordCount = 2 Then cell.Font.Size = 14 ' ElseIf wordCount >= 3 Then cell.Font.Size = 14 End If cell.Font.Bold = True cell.Font.Name = "Arial" End If Next cell Application.EnableEvents = True ' End If End Sub

جرب كود البحث (ادخال رقم البحث في الخالية j5 لكن ما زال ينقصه بعد التعديلات ليقوم بعرض البيانات بالترتيب في القائمه لعلى احد من الاخوه ان يساعدك Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$J$5" Then If Not IsEmpty(Target.Value) Then Dim wsData As Worksheet Set wsData = ThisWorkbook.Sheets("البيانات") Dim searchRange As Range Dim foundCell As Range Set searchRange = wsData.Range("A:A") Set foundCell = searchRange.Find(What:=Target.Value, LookIn:=xlValues, LookAt:=xlWhole) If Not foundCell Is Nothing Then Dim rowNum As Long rowNum = foundCell.Row Dim dataRange As Range Set dataRange = wsData.Range("A" & rowNum & ":R" & rowNum) Dim wsSource As Worksheet Set wsSource = ThisWorkbook.Sheets("الرئيسية") Dim targetRange As Range Set targetRange = wsSource.Range("K7:K24") targetRange.Value = Application.Transpose(dataRange.Value) Else wsSource.Range("K7:K24").Value = "" End If Else wsSource.Range("K7:K24").Value = "" End If End If End Sub

جرب الكود التالي Private Sub CommandButton1_Click() Dim sourceValues() As Variant sourceValues = Array("C8", "C10", "C12", "C14", "C16", "C18", "F8", "F10", "F12", "F14", "F16", "F18", "I8", "I10", "I12", "I14", "I16", "I18 ") Dim wsSource As Worksheet Set wsSource = ThisWorkbook.Sheets("الرئيسية") Dim wsTarget As Worksheet Set wsTarget = ThisWorkbook.Sheets("البيانات") Dim lastRow As Long lastRow = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row Dim searchRange As Range Set searchRange = wsTarget.Range("A2:A" & lastRow) Dim foundRow As Range Set foundRow = searchRange.Find(What:=wsSource.Range("C8").Value, LookIn:=xlValues, LookAt:=xlWhole) If foundRow Is Nothing Then For i = 0 To UBound(sourceValues) wsSource.Range(sourceValues(i)).Copy wsTarget.Cells(lastRow + 1, i + 1) Next i Else For i = 0 To UBound(sourceValues) wsTarget.Cells(foundRow.Row, i + 1).Value = wsSource.Range(sourceValues(i)).Value Next i End If End Sub

¨ جرب الكود التالي لعله المطلوب الخاص بي ترحيل Private Sub CommandButton1_Click() ' ÊÍÏíÏ ÇáÕÝÍÉ ÇáÃÕáíÉ Dim wsSource As Worksheet Set wsSource = ThisWorkbook.Sheets("الرئسية") ' ÊÍÏíÏ ÇáÕÝÍÉ ÇáåÏÝ Dim wsTarget As Worksheet Set wsTarget = ThisWorkbook.Sheets("البيانات") ' ÊÑÍíá ÇáÈíÇäÇÊ Dim lastRow As Long lastRow = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row Dim searchRange As Range Set searchRange = wsTarget.Range("A2:A" & lastRow) ' äØÇÞ ÇáÈÍË Ýí ÇáÕÝÍÉ ÇáåÏÝ If Application.WorksheetFunction.CountIf(searchRange, wsSource.Range("C8").Value) = 0 Then ' äÓÎ ÑÞã ÇáãÚÇãáÉ ÅÐÇ áã íÊã ÇáÚËæÑ Úáíå Ýí ÇáÕÝÍÉ ÇáåÏÝ wsSource.Range("C8").Copy wsTarget.Cells(lastRow + 1, 1) wsSource.Range("C10").Copy wsTarget.Cells(lastRow + 1, 2) wsSource.Range("C12").Copy wsTarget.Cells(lastRow + 1, 3) wsSource.Range("C14").Copy wsTarget.Cells(lastRow + 1, 4) wsSource.Range("C16").Copy wsTarget.Cells(lastRow + 1, 5) wsSource.Range("C18").Copy wsTarget.Cells(lastRow + 1, 6) wsSource.Range("F8").Copy wsTarget.Cells(lastRow + 1, 7) wsSource.Range("F10").Copy wsTarget.Cells(lastRow + 1, 8) wsSource.Range("F12").Copy wsTarget.Cells(lastRow + 1, 9) wsSource.Range("F14").Copy wsTarget.Cells(lastRow + 1, 10) wsSource.Range("F16").Copy wsTarget.Cells(lastRow + 1, 11) wsSource.Range("F18").Copy wsTarget.Cells(lastRow + 1, 12) wsSource.Range("I8").Copy wsTarget.Cells(lastRow + 1, 7) wsSource.Range("I10").Copy wsTarget.Cells(lastRow + 1, 8) wsSource.Range("I12").Copy wsTarget.Cells(lastRow + 1, 9) wsSource.Range("I14").Copy wsTarget.Cells(lastRow + 1, 10) wsSource.Range("I16").Copy wsTarget.Cells(lastRow + 1, 11) wsSource.Range("I18").Copy wsTarget.Cells(lastRow + 1, 12) Else ' ÇÓÊÈÏÇá ÇáÈíÇäÇÊ ÅÐÇ Êã ÇáÚËæÑ Úáì ÑÞã ÇáãÚÇãáÉ ãæÌæÏðÇ ÈÇáÝÚá Ýí ÇáÕÝÍÉ ÇáåÏÝ Dim foundRow As Range Set foundRow = searchRange.Find(What:=wsSource.Range("C8").Value, LookIn:=xlValues, LookAt:=xlWhole) If Not foundRow Is Nothing Then wsTarget.Cells(foundRow.Row, 2).Value = wsSource.Range("C10").Value wsTarget.Cells(foundRow.Row, 3).Value = wsSource.Range("C12").Value wsTarget.Cells(foundRow.Row, 4).Value = wsSource.Range("C14").Value wsTarget.Cells(foundRow.Row, 5).Value = wsSource.Range("C16").Value wsTarget.Cells(foundRow.Row, 6).Value = wsSource.Range("C18").Value wsTarget.Cells(foundRow.Row, 7).Value = wsSource.Range("F10").Value wsTarget.Cells(foundRow.Row, 8).Value = wsSource.Range("F12").Value wsTarget.Cells(foundRow.Row, 9).Value = wsSource.Range("F14").Value wsTarget.Cells(foundRow.Row, 10).Value = wsSource.Range("F16").Value wsTarget.Cells(foundRow.Row, 11).Value = wsSource.Range("F18").Value wsTarget.Cells(foundRow.Row, 12).Value = wsSource.Range("I8").Value wsTarget.Cells(foundRow.Row, 13).Value = wsSource.Range("I10").Value wsTarget.Cells(foundRow.Row, 14).Value = wsSource.Range("I12").Value wsTarget.Cells(foundRow.Row, 15).Value = wsSource.Range("I14").Value wsTarget.Cells(foundRow.Row, 16).Value = wsSource.Range("I16").Value End If End If End Sub

السلام عليكم ورحمة الله وبركاته ارجو المساعدة نحن مجموعة من الشباب (20) شخص نجمع في كل شهر مبلغ 100 دينار لكل شخص، قومنا بعمل قرعة بيننا على من يأخذ مبلغ 2000 دينار، من يأخذ في شهر الاول وفي شهر الثاني وفي شهر الثالث وهكدا حتى اخير وحد ، وطبعاً يستمر في الدفع حتى تكتمل المجموعة وبعد أن يتحصل كل الشباب على نصيبهم وتكتمل المجموعة، وذلك لا يتم إلا بعد 20 أشهر قومت بعمل قائمة من الاسماء الشباب في ملف اكسيل اريد طريقة في كل 4 من شهر يتم نسخ اسم شخص المستفيد من عمود C الى عمود D وشهر في عمود E ويتم وضع لون على سطر شخص المستفيد اريد تطبيق طريقة كما في سطر ٣ القرعة.xlsm

عمل رائع جزاك الله خيرا ممكن كل شهر يتم تلوين اسم المستحق