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

السلام عليكم ورحمة الله اليك المرفق ربما يكون هذا هو الحل 2017صيفية برمجية 2استعلام.rar

السلام عليكم ورحمة الله جرب هذا الملف ربما يفيدك ملحوظة هامة : يجب أن تكون اسماء الشيتات بالملف الرئيسى " All_To_one " هى نفس اسماء الملفات المراد ترحيلها اليه All_To_one.rar

السلام عليكم ورحمة الله محاولة لا اضمن لها النجاح لأن العمل بدون الملف هو مضيعة للوقت استبدل الكود السابق بنفس الكود مع تعديل تخيلى Private Sub CommandButton1_Click() On Error Resume Next Dim i As Integer, LastR As Long, ws, ws1 As Worksheet Set ws = ThisWorkbook.Sheets("البيانات") Set ws1 = ThisWorkbook.Sheets("المدراء") LastRow = ws.Cells(Rows.Count, "B").End(xlUp).Row + 1 LastRow1 = ws1.Cells(Rows.Count, "B").End(xlUp).Row + 1 For i = 2 To 15 UserForm1.ComboBox1.Clear For T = 2 To LastRow For S = 2 To LastRow1 If OptionButton1.Value = True Then If TextBox1.Text = Mid(ws1.Cells(T, 3).Text, 1, Len(TextBox1.Text)) Then UserForm1.ComboBox1.AddItem ws1.Cells(T, 3) UserForm1.Controls("TextBox" & i).Value = ws1.Cells(T, i).Value UserForm1.CommandButton4.Enabled = True Unload Me End If Else If OptionButton2.Value = True Then If TextBox1.Text = Mid(ws.Cells(S, 3).Text, 1, Len(TextBox1.Text)) Then UserForm1.ComboBox1.AddItem ws.Cells(S, 3) UserForm1.Controls("TextBox" & i).Value = ws.Cells(S, i).Value UserForm1.CommandButton4.Enabled = True Unload Me End If End If End If Next Next Next UserForm1.ComboBox1.ListIndex = 0 If UserForm1.TextBox2.Text = "" Then MsgBox "??C C???U? U?? ????I", vbInformation + vbMsgBoxRight, "?E??E C?E?E" UserForm1.CommandButton3.Enabled = False End Sub

السلام عليكم ورحمة الله اجعل المعادلة فى شيت النتيجة هكذا =VLOOKUP(A6;vv;5;0) ثم اسحب نزولا

السلام عليكم ورحمة الله تفضل اخى الكريم 1.rar

السلام عليكم ورحمة الله هذا الامر يسمح بتلوين الصف من العمود 2 حتى العمود 17 وبعد التجريب هل تريد تلوين الصف الى آخر عمود فى الشيت

السلام عليكم ورحمة الله ضع السطر التالى بين السطر الثامن و السطر التاسع .Cells(LastRow, i).Interior.ColorIndex = 10

السلام عليكم ورحمة الله شكرا للمبدع دائما جعله الله فى ميزان حسناتك

السلام عليكم ورحمة الله استخدم الكود التالى Sub EditData() Const x = 155 Dim cel As Range, z As Single For Each cel In ورقة1.Range("F4:F" & ورقة1.Range("F" & Rows.Count).End(xlUp).Row) If cel.Value = x Then cel.Offset(0, 22) = cel.Offset(0, 23) + cel.Offset(0, 24) cel.Offset(0, 24) = cel.Offset(0, 25) cel.Offset(0, 25) = cel.Offset(0, 26) cel.Offset(0, 26) = cel.Offset(0, 27) cel.Offset(0, 27) = cel.Offset(0, 28) z = WorksheetFunction.Round(cel.Offset(0, 27) * Range("AG3"), 2) cel.Offset(0, 33) = z End If Next End Sub

اخى الكريم الاستاذ حسين السلام عليكم ورحمة الله اعتقد اننى قد عملت على هذا الملف من حوالى ثلاثة اسابيع وظننت انى قد وفقت فى الحل ولم ادخل الى الموضوع مرة اخرى فأعتذر اننى لم ارى ردودك اواستفساراتك مرة اخرى وعند عرضك للموضوع مرة اخرى تأكدت من خطـأى فى تفسير المطلوب لذلك لم تكن النتيجة مرضية وليأذن لى استاذى معلمى الاستاذ ياسر بعرض هذا الكود حيث ان نتائجه تطابق نفس المخرجات الواردة بالملف عدا الصف رقم 18 فالخطأ من عند الاستاذ حسين وليس من الكود ودمتم بالف خير Sub Collect() Dim sh As Worksheet, ws As Worksheet Dim x As Long Set ws = Sheets("الرئيسية") ws.Range("E4:E50").ClearContents For R = 4 To ws.Range("D" & Rows.Count).End(xlUp).Row Z = 0 For Each sh In Worksheets If sh.Name <> "الرئيسية" And sh.Name <> "namodaj" And sh.Name <> "طباعة" Then For x = 9 To sh.Range("B" & Rows.Count).End(xlUp).Row If Year(sh.Cells(x, 2)) = Year(ws.Cells(R, 4)) And _ Month(sh.Cells(x, 2)) = Month(ws.Cells(R, 4)) Then Z = Z + sh.Cells(x, 3).Value ws.Cells(R, 5) = Z End If Next End If Next Next End Sub

السلام عليكم ورحمة الله استبدل الكود السابق بهذا الكود Sub EditData() Const x = 155 Dim cel As Range, z As Single For Each cel In ورقة1.Range("A4:A" & ورقة1.Range("A" & Rows.Count).End(xlUp).Row) If cel.Value = x Then cel.Offset(0, 1) = cel.Offset(0, 1) + cel.Offset(0, 2) cel.Offset(0, 2) = cel.Offset(0, 3) cel.Offset(0, 3) = cel.Offset(0, 4) cel.Offset(0, 4) = cel.Offset(0, 5) cel.Offset(0, 5) = cel.Offset(0, 6) z = WorksheetFunction.Round(cel.Offset(0, 1) * Range("G3"), 2) cel.Offset(0, 6) = z End If Next End Sub

السلام عليكم ورحمة الله استبدل الكود السابق بهذا الكود Sub EditData() Const x = 155 Dim cel As Range For Each cel In Range("A4:A" & Range("A" & Rows.Count).End(xlUp).Row) If cel.Value = x Then cel.Offset(0, 1) = cel.Offset(0, 1) + cel.Offset(0, 2) cel.Offset(0, 2) = cel.Offset(0, 3) cel.Offset(0, 3) = cel.Offset(0, 4) cel.Offset(0, 4) = cel.Offset(0, 5) cel.Offset(0, 5) = cel.Offset(0, 6) End If Next End Sub

السلام عليكم ورحمة الله انسخ هذا الكود والصقه فى موديول جديد واربطه بالزر الموجود Sub EditData() Const x = 155 Dim cel As Range For Each cel In Range("A4:A10") If cel.Value = x Then cel.Offset(0, 1) = cel.Offset(0, 1) + cel.Offset(0, 2) cel.Offset(0, 2) = cel.Offset(0, 3) cel.Offset(0, 3) = cel.Offset(0, 4) cel.Offset(0, 4) = cel.Offset(0, 5) cel.Offset(0, 5) = cel.Offset(0, 6) End If Next End Sub

اخى الكريم السلام عليكم ورحمة الله تم تنفيذ كل ماطلبته ما عدا تلوين الشيت لانه سيستغرق وقتا طويلا اثناء التنفيذ على العموم هو موجود فى موديول 2 وعلى نطاق محدود جرب بنفسك اليك الملف بعد التعديل ارصدة.rar

السلام عليكم ورحمة الله انسخ هذا الكود فى موديول جديد وخصص له زر فى الورقة نموذج Sub Copy_AddSheet() Dim x As String Sheet1.Range("A2:E" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row).Copy x = WorksheetFunction.Text(Now(), Format("dd-mm-yyyy")) For i = 1 To Sheets.Count If Sheets(i).Name = x Then Exit Sub Next i Sheets.Add With ActiveSheet .Name = x .Range("A2").PasteSpecial xlPasteValues .Range("A2").PasteSpecial xlPasteFormats .Range("A2").PasteSpecial xlPasteColumnWidths End With Application.CutCopyMode = False End Sub

بارك الله فيك و جعلها فى ميزان حسناتك دائما من السباقين الى الخير

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

السلام عليكم ورحمة الله اخى الكريم / قلب باكى اخى الكريم كعبلاوى ارجو النظر الى المرفق التالى وانا معكم باذن الله بعد العودة من العمل Test_Sheet.rar

السلام عليكم ورحمة الله اخى الكريم ربما طلبك فى هذا الملف قصول و لجان.rar

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

السلام عليكم ورحمة الله اخى الحبيب تفضل التحصيل.rar

الحمد لله رب العاملين اشكرك على كلماتك الطيبة

السلام عليكم ورحمة الله تفضل اخى الكريم تجميع بيانات.rar

السلام عليكم ورحمة الله تفضلى New folder (2).rar

السلام عليكم ورحمة الله ضع هذا الكود فى حدث الصفحة وسيعمل تلقائيا دون تدخل منك Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column <> 1 Then Exit Sub Dim cel As Range For Each cel In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row) cel.Offset(0, 1).Value = cel Next End Sub