ابراهيم الحداد

السلام عليكم ورحمة الله استبدل الكود المرفق بالملف بهذا الكود ( هو تعديل بسيط ) Private Sub CommandButton1_enter() Sheets(1).Activate lrow = Range("i" & Rows.Count).End(xlUp).Row Range("i" & lrow + 1).Value = TextBox1.Value Range("i" & lrow + 1).Offset(0, 1).Value = TextBox2.Value For Each c In Range("B3:B1000") If c.Value = Range("i" & lrow + 1) Then c.Offset(0, 2) = Range("i" & lrow + 1).Offset(0, 1).Value End If Next TextBox1.Value = "" TextBox2.Value = "" TextBox1.SetFocus End Sub

السلام عليكم ورحمة الله ضع هذا الكود فى حدث الفورم Private Sub TextBox1_Change() Dim Arr As Variant, Temp As Variant Dim i As Integer, j As Integer, p As Integer Dim x, y As Integer Arr = Range("A2:E12").Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 1) = Me.TextBox1.Value Then p = p + 1 For j = 1 To UBound(Arr, 2) Temp(p, j) = Arr(i, j) Next x = x + Temp(p, 3) y = y + Temp(p, 4) End If Next Me.ListBox1.List = Temp Me.TextBox2 = x Me.TextBox3 = y End Sub

السلام عليكم ورحمة الله اجعل الكود هكذا الرجاء فقط تحديد الخلية التى تحتوى اسم الموظف و ليس الصف كله قبل تنفيذ الكود Sub DelRows() Dim Sh As Worksheet, Msg As String Dim Nam As String Dim i As Long, LR As Long Nam = ActiveCell.Value Msg = MsgBox("من كافة الشيتات" & " " & Nam & " " & "هل تريد فعلا ازالة السيد / ", vbYesNo) For Each Sh In Worksheets For i = 1000 To 4 Step -1 If Nam = "" Then Exit Sub If Sh.Cells(i, 1) = Nam Or Sh.Cells(i, 2) = Nam Then If Msg = vbYes Then On Error Resume Next Sh.Rows(i).Delete Else: Exit Sub End If End If Next Next End Sub

السلام عليكم ورحمة الله استخدم هذا الكود Sub DelRows() Dim Sh As Worksheet, Msg As String Dim Nam As String Dim i As Long, LR As Long Nam = ActiveCell.Value Msg = MsgBox("من كافة الشيتات" & " " & Nam & " " & "هل تريد فعلا ازالة السيد / ", vbYesNo) For Each Sh In Worksheets For i = 1000 To 4 Step -1 If Nam = "" Then Exit Sub If Sh.Cells(i, 1) = Nam Or Sh.Cells(i, 2) = Nam Then If Msg = vbYes Then Sh.Rows(i).Delete Else: Exit Sub End If End If Next Next End Sub

السلام عليكم ورحمة الله جرب هذه المعادلة =COUNTIF($B$2:$C$7;$A14 &"*")

السلام عليكم ورحمة الله بارك الله فيكم احبتى الكرام و كل اللذين شرفونى بالرد و الثناء على هذا الموضوع بالنسبة للاخ الكريم / عبد الحميد الشافعى اشكرك على هذا الاطراء الذى لا استحقه فأنا معلم خبير باحدى المدارس التجارية بجنوب الصعيد و على وشك الخروج على المعاش على فكرة و لهذا سميت عضويتى باسم زيزو العجوز و اى استفسار بالنسبة للشيت كنترول التجارى للصفين الاول و الثانى ستجدنى ان شاء الله فى انتظارك و على نفس المنتدى ... منتدنا الحبيب اوقيسنا و الله الموفق و المستعان

السلام عليكم ورحمة الله استخدم هذه المعادلة =IF(OR(VALUE(MID(B2;SEARCH("/";B2;1)+1;3)) >140;VALUE(LEFT(B2;SEARCH("/";B2;1)-1))>90 );"ضغط عالى";"")

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

السلام عليكم ورحمة الله لن يعمل معك الكود و خلايا الاسم فارغة

السلام عليكم ورحمة الله استخدم هذا الكود Sub Absents() Dim C As Range, M As String Dim R As Integer R = 4 Do While Cells(R, 1) <> "" For Each C In Range("B" & R & ":AC" & R) If C.Value = "غ" Then M = Day(Cells(2, C.Column)) & "," & M Range("AD" & R) = M End If Next R = R + 1 M = "" Loop End Sub

السلام عليكم ورحمة الله فى حالة عدم وجود اسم العميل او اسم المخزن لن يعمل معك الكود اليك الكود Sub StatmentCS() Dim ws As Worksheet, Sh As Worksheet Dim CusmName As String, StorName As String Dim Arr As Variant, Temp As Variant Dim LR As Long, i As Long, j As Long, p As Long Set ws = Sheets("ورقة1") Set Sh = Sheets("ورقة2") StorName = Sh.Range("C2") CusmName = Sh.Range("F2") LR = ws.Range("D" & Rows.Count).End(xlUp).Row Sh.Range("A5:L" & Sh.Range("D" & Rows.Count).End(xlUp).Row + 1).ClearContents Arr = ws.Range("A5:L" & LR).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 12) = StorName And Arr(i, 4) = CusmName Then p = p + 1 For j = 1 To UBound(Arr, 2) Temp(p, j) = Arr(i, j) Next End If Next If p > 0 Then Sh.Range("A5").Resize(p, UBound(Temp, 2)).Value = Temp End Sub

السلام عليكم ورحمة الله استخدم هذا الكود Sub Tarhil() Dim ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Temp As Variant Dim LR As Long, i As Long, j As Long, p As Long Dim Setlt As String Set ws = Sheets("كشف السداد") Set Sh = Sheets("حساب العملاء") Setlt = "تم السداد" LR = ws.Range("B" & Rows.Count).End(xlUp).Row Arr = ws.Range("B5:F" & LR).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 5) = Setlt Then p = p + 1 For j = 1 To 4 Temp(p, j) = Arr(i, Choose(j, 1, 2, 3, 5)) Next End If Next If p > 0 Then Sh.Range("B4").Resize(p, UBound(Temp, 2)).Value = Temp End Sub

السلام عليكم ورحمة الله استخدم هذين الكودين و اربط الزر بالكود الثانى وليس الاول Sub Trans1() Dim ws As Worksheet, Sh As Worksheet Dim C As Range, x As Integer, y As Integer, z As Integer Application.ScreenUpdating = False Set ws = Sheets("Names Data") Set Sh = Sheets("الترحيل") z = WorksheetFunction.Max(ws.Range("A10:A" & ws.Range("A" & Rows.Count).End(xlUp).Row)) For Each C In Sh.Range("A10:A2000") x = C.Row - 9 y = x Mod 4 If y <> 0 Then p = p + 1 If p > z Then Exit Sub C.Value = p End If Next Application.ScreenUpdating = True End Sub Sub Trans2() Call Trans1 Dim ws As Worksheet, Sh As Worksheet Dim C2 As Range Set ws = Sheets("Names Data") Set Sh = Sheets("الترحيل") Application.ScreenUpdating = False For Each C2 In Sh.Range("A10:A" & Sh.Range("A" & Rows.Count).End(xlUp).Row) If C2.Value <> "" Then C2.Offset(0, 1) = WorksheetFunction.VLookup(C2, ws.Range("A10:C1400"), 2, 0) C2.Offset(0, 2) = WorksheetFunction.VLookup(C2, ws.Range("A10:C1400"), 3, 0) End If Next Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله استخدم هذا الكود Sub زر_ترحيل() Dim ws As Worksheet, Sh As Worksheet Dim C As Range Dim x As Integer, R As Integer, LR As Integer Set ws = Sheets("Names Data") Set Sh = Sheets("الترحيل") Application.ScreenUpdating = False R = 10 LR = ws.Range("C" & Rows.Count).End(xlUp).Row Do While R < LR For Each C In Sh.Range("A10:A" & ws.Range("C" & Rows.Count).End(xlUp).Row) If C.Interior.ColorIndex <> 3 Then C.Value = ws.Range("A" & R).Value C.Offset(0, 1).Value = ws.Range("B" & R).Value C.Offset(0, 2).Value = ws.Range("C" & R).Value End If R = R + 1 Next Loop Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله استخدم هذا الكود Sub زر_ترحيل() Dim ws As Worksheet, Sh As Worksheet Set ws = Sheets("Names Data") Set Sh = Sheets("الترحيل") ws.Range("C10:C" & ws.Range("C" & Rows.Count).End(xlUp).Row).Copy Sh.Range("C10").PasteSpecial xlPasteValues Application.CutCopyMode = False End Sub

السلام عليكم ورحمة الله استخدم هذا الكود Sub زر_ترحيل() Dim ws As Worksheet, Sh As Worksheet Set ws = Sheets("Names Data") Set Sh = Sheets("الترحيل") ws.Range("A10:C" & ws.Range("C" & Rows.Count).End(xlUp).Row).Copy Sh.Range("A10").PasteSpecial xlPasteValues Application.CutCopyMode = False End Sub

السلام عليكم ورحمة الله تفضل كشف حساب مدين ودائن.rar

السلام عليكم ورحمة الله ضع المعادلة الاولى فى لبخلية "E2" ثم اسحب نزولا =IF([@مدين]>[@دائن];[@مدين]-[@دائن];0) ثم ضع المعادلة التالية فى الخلية "F2" ثم اسحب نزولا =IF([@دائن]>[@مدين];[@دائن]-[@مدين];0)

السلام عليكم ورحمة الله عذرا لا تنسى الضغط على CTRL+SHIFT+ENTER لكى تعمل معك المعادلة

السلام عليكم ورحمة الله استخدم هذه المعادلة بدلا من المعادلة الموجودة بالملف =IF(I2=Sheet3!$A$2:$A$54;INDEX(Sheet3!$A$2:$C$54;MATCH(TRUE;ISNUMBER(FIND(Sheet3!$B$2:$B$54;G2));0);3);"")

السلام عليكم ورحمة الله استخدم الكود الآتى Sub RepTxt_Num() Dim C As Range, i As Long, x As String, Z As String For Each C In Range("AI5:AI" & Range("AI" & Rows.Count).End(xlUp).Row) For i = 1 To Len(C) x = Mid(C, i, 1) y = Application.HLookup(x, Range("A1:AF2"), 2, 0) Z = Z & y C.Offset(0, 1) = Z Next Z = "" Next End Sub

السلام عليكم ورحمة الله اولا : ضع المعادلة التالية فى الخلية "B11 " ثم اسحب نزولا الى آخر صف =IF(C11="";"";SUBTOTAL(3;$C$11:C11)) ثانيا ضع الكود التالى بدلا من الكود السابق Sub DelRows() Dim ws As Worksheet, C As Range Dim x As Date, LR As Integer, i As Integer Application.ScreenUpdating = False Set ws = Sheets("ورقة1") LR = ws.Range("F" & Rows.Count).End(xlUp).Row For i = 11 To LR If ws.Cells(i, 6).Value <= Date Then ws.Range(ws.Cells(i, 3), ws.Cells(i, 6)).ClearContents End If Next Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله اجعل المعادلة فى العمود " K " هكذا =COUNTIF($J$7:$J7;J7) ثم اسحب نزولا

السلام عليكم ورحمة الله اليك الملف فقط اضغط على الزر الموجود بورقة1 حذف الشيكات المستحقة.rar

السلام عليكم ورحمة استخدم هذا الكود و لا يوجد اى لزوم للمعادلة فى العمود "I" Sub DelRows() Dim ws As Worksheet, C As Range Dim x As Date, LR As Integer, i As Integer Set ws = Sheets("ورقة1") LR = ws.Range("F" & Rows.Count).End(xlUp).Row For i = LR To 11 Step -1 If ws.Cells(i, 6).Value <= Date Then ws.Cells(i, 6).EntireRow.Delete End If Next End Sub