عبدالله باقشير

استبدل كود زر النسخ بهذا الكود Private Sub ButtonSaveFil_Click() Dim iC As Integer iC = Me.ListFind.ListCount If iC = 0 Then GoTo 1 '------------------------ Application.ScreenUpdating = False With ورقة3 .Range("A1").Resize(1, ContColmn).Value = sRng.Value .Range("A2").Resize(iC, ContColmn).Value = Me.ListFind.List .UsedRange.Columns.AutoFit End With Application.ScreenUpdating = True Unload Me 1 End Sub

شاهد المرفق 2003 قاعدة بيانات للصور.rar

السلام عليكم شاهد المرفق 2003 مساعده في فورم ادخال وترحيل1.rar

السلام عليكم الشكر واصل للاخ ابوحنين حفظه الله بالنسبة للطلب الاول: شاهد المرفق 2003 مساعدة في فورم ادخال وترحيل .rar

الاخ الفاضل /هاني عدلي

السلام عليكم شاهد المرفق 2003 قاعدة بيانات لصور الأصناف1.rar

افرد كل خلية بما يقابلها في البيانات مثلا Sheets("السلف").Cells(ii, "A").Value = .Cells(i, "A").Value Sheets("السلف").Cells(ii, "B").Value = .Cells(i, "C").Value

بسيطة ان شاء الله فقط عندي سؤال فيما اذا كانت لا توجد اي معايير هل تريد جلب جميع البيانات او ايقاف الكود في هذه الحالة ؟؟ الكود التالي لا يشترط ايقاف البيانات في عدم وجود اي معايير Sub Solaf() Dim ib As Boolean Dim tst As Integer, tst1 As Integer, tst2 As Integer Dim LastRow As Long, i As Long, ii As Long Dim SText As String Dim SText1 As String Dim StDate As Double, EndDate As Double With Sheets("السلف") .Range("A7:L10000").ClearContents SText = .Range("B2") SText1 = .Range("C2") If IsDate(.Range("B3")) And IsDate(.Range("B4")) Then StDate = .Range("B3") EndDate = .Range("B4") Else: ib = True End If End With ii = 7 With Sheets("yaomea") LastRow = .Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To LastRow '=============================== If Len(Trim(SText)) = 0 Then tst = 1 Else tst = Abs(CStr(.Cells(i, "J")) = SText) If Len(Trim(SText1)) = 0 Then tst1 = 1 Else tst1 = Abs(CStr(.Cells(i, "N")) = SText1) If ib Then tst2 = 1 Else tst2 = Abs(.Cells(i, "d").Value2 >= StDate) * Abs(.Cells(i, "d").Value2 <= EndDate) '=============================== If tst * tst1 * tst2 Then Sheets("السلف").Cells(ii, "A").Resize(1, 12).Value = .Cells(i, "A").Resize(1, 12).Value ii = ii + 1 End If Next End With End Sub

السلام عليكم جرب الكود التالي: واشعرنا بالنتيجة Sub Solaf() Dim ib As Boolean Dim tst1 As Integer, tst2 As Integer Dim LastRow As Long, i As Long, ii As Long Dim SText As String Dim SText1 As String Dim StDate As Double, EndDate As Double With Sheets("السلف") .Range("A7:L10000").ClearContents SText = .Range("B2") SText1 = .Range("C2") If IsDate(.Range("B3")) And IsDate(.Range("B4")) Then StDate = .Range("B3") EndDate = .Range("B4") Else: ib = True End If End With ii = 7 With Sheets("yaomea") LastRow = .Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To LastRow If CStr(.Cells(i, "J")) = SText Then '=============================== If Len(Trim(SText1)) = 0 Then tst1 = 1 Else tst1 = Abs(CStr(.Cells(i, "N")) = SText1) '---------- If ib Then tst2 = 1 Else tst2 = Abs(.Cells(i, "d").Value2 >= StDate) * Abs(.Cells(i, "d").Value2 <= EndDate) '=============================== If tst1 * tst2 Then Sheets("السلف").Cells(ii, "A").Resize(1, 12).Value = .Cells(i, "A").Resize(1, 12).Value ii = ii + 1 End If End If Next End With End Sub المرفق 2003-2007 solaf.rar

الله يحفظكم من كل مكروه اخي ياسر استفسارك في محله اخي عبدالله تقبلوا تحياتي وشكري

جمعة مباركة اخي الحبيب عبدالله الله يسلمك ويحفظك من كل مكروه تقبل تحياتي وشكري

السلام عليكم الاكواد كثيرة في الملف يصعب من خلالها تنفيذ الطلب في الملف المرفق عموما ضع هذا الكود في حدث الورقة Sheet2 Private Sub Worksheet_Change(ByVal Target As Range) Dim Cel As Range Dim M As Integer, R As Integer '---------- On Error GoTo 1 '---------- Set Cel = Sheet1.Range("LIST") '---------- If Target.Address = Range("A12").Address Then M = WorksheetFunction.Match(CStr(Target), Cel.Columns(1), 0) End If '---------- 1: If Err Then Err.Clear Else R = M + Cel.Row - 1 With Cel.Worksheet If .Cells(R, "N") = "X" Then .Cells(R, "N").ClearContents Else .Cells(R, "N") = "X" End If End With End If Set Cel = Nothing End Sub Totals2.rar

انا عملتها من شهر يناير الى الشهر المختار في القائمة هذا حسب ما فهمت هل تريد للشهر المختار فقط غير التالي: المعادلة في العمود بي =SUM(OFFSET(kh_Rng;$E$2;MATCH($A8;INDEX(kh_Rng;1;0);0)-1;1;1)) المعادلة في العمود سي =SUM(OFFSET(kh_Rng;$E$2;MATCH($A8;INDEX(kh_Rng;1;0);0);1;1)) ايضا غير المعادلة في الخلية E2 =N(MONTH($D$3)+1)

السلام عليكم شاهد المرفق مع ملاحظة ان المعادلة في العمود بي تختلف عن المعادلة في العمود سي المعادلة في العمود بي =SUM(OFFSET(kh_Rng;0;MATCH($A8;INDEX(kh_Rng;1;0);0)-1;$E$2;1)) المعادلة في العمود سي =SUM(OFFSET(kh_Rng;0;MATCH($A8;INDEX(kh_Rng;1;0);0);$E$2;1)) حيث النطاق kh_Rng هو =استاذ!$H$10:$M$23 المرفق 2003 2007 Book1.rar

حفطك الله ورعاك لا يوجد داعي للدخول الى صفحات البيانات حط ازرار البحث في اي ورقة اخرى ولنقل الرئيسية جرب واشعرنا بالنتيجة

السلام عليكم اكرمكم الله جميعا تقبلوا تحياتي وشكري

ضع هذه الاكواد في موديل Option Explicit Sub Auto_Open() kh_wVisible True End Sub Sub Auto_Close() kh_wVisible False ThisWorkbook.Close Not CBool(ThisWorkbook.Saved) End Sub Sub kh_wVisible(ibol As Boolean) Dim nBook As String nBook = ThisWorkbook.Name With Windows(nBook) If .Visible = Not ibol Then .Visible = ibol End With End Sub شاهد المرفق 2003-2007 th1.rar

حفظك الله اخي ابوخليل واكرمك في الدارين تقبل تحياتي وشكري

بدلا من اضافة قائمة داخل الفورم اعمل زر لكل صفحة واربط الزر بالكود الخاص بالصفحة ادناه Option Explicit '====================================================== '====================================================== Sub kh_Find1() kh_Find Sheets("البيانات").Range("B3:L3") End Sub Sub kh_Find2() kh_Find Sheets("البيانات 2").Range("B3:I3") End Sub Sub kh_Find3() kh_Find Sheets("البيانات3").Range("B3:E3") End Sub Sub kh_Find(vRng As Range) Dim ContRow As Long '========================== On Error GoTo 1 '========================== With vRng ContRow = .Worksheet.Cells(Rows.Count, .Column).End(xlUp).Row - .Row End With '========================== If ContRow = 0 Then MsgBox "لا توجد بيانات اعتمادا على آخر صف في العمود الاول" Else With UserFormSearch .kh_RngSet vRng, vRng.Offset(1, 0).Resize(ContRow) .Show End With End If 1: Set vRng = Nothing End Sub وقم بحذف الكود السابق المربوط به الزر لفتح الفورم فورم بحث بامكانية التصفية.rar

السلام عليكم ورحمة الله وبركاته الشكر واصل للفاضل ابو حنين ولاثراء الموضوع هذا حل آخر ياستخدام دالة Match Private Sub CommandButton1_Click() Dim vM Dim i As Integer On Error GoTo KH_Err vM = WorksheetFunction.Match(CDbl(CDate(Me.ComboDays)), MyRng, 0) For i = 1 To 40 MyRng.Cells(vM, i + 1).Value = Me.Controls("TextBox" & i).Value Next '================ KH_Err: If Err Then MsgBox "Err.Number : " & Err.Number Err.Clear Else: MsgBox "ok" End If End Sub date3.rar

بالنسبة لهذا تجده في الموضوع http://www.officena.net/ib/index.php?showtopic=42121&st=20 المشاركة 24 بالنسبة لهذا ما فائدة الفراغ هذا اللي في بداية القائمة

السلام عليكم ورحمة الله وبركاته اذا اردتهم بشكل عام بدون وضع بيانات في الشيت بحيث يكون عندك قائمة بالاشهر وعند اختيارك الشهر تحصل على قائمة بايام هذا الشهر في الفورم تحتاج الى قائمتين ComboDays ComboMonth وضع هذه الاكود في الفورم Private Sub ComboMonth_Click() Dim d As Double, yy As Double Dim mm As Integer yy = Year(Date) Me.ComboDays.Clear mm = Me.ComboMonth.ListIndex + 1 For d = DateSerial(yy, mm, 1) To DateSerial(yy, mm + 1, 0) Me.ComboDays.AddItem Format(d, "dd/mm/yyyy") Next End Sub Private Sub UserForm_Activate() For i = 1 To 12 Me.ComboMonth.AddItem MonthName(i) Next Me.ComboMonth.Style = 2 Me.ComboDays.Style = 2 End Sub المرفق 2003 date.rar

السلام عليكم تقبل الله منا ومنكم صالح الاعمال و كل عام وانتم بخير

السلام عليكم ورحمة الله وبركاته عيدكم مبارك وكل عام وانتم بخير تقبل الله منا ومنكم صالح الاعمال ودمتم في حفظ الله