أبو حنــــين

لو ارسلت الملف و به النتائج المتوقعة و يستحسن اكثر من مثال جرب هذا Sub AAAAAA() Dim sh As Worksheet, v As Double, x As Integer Set sh = Sheets("a") With sh .Range("E13:E42") = "" For x = 1 To Val(.Range("G10").Value) .Cells(x + 12, 5) = .Range("D10").Value Next End With End Sub

السطر التالي Range("A1").Select قبل الجملة : End Sub

الملف يعمل عندي كما طلبت المرفق 22.rar

مرحبا جرب هذا الكود Sub AAAAAA() Dim sh As Worksheet, v As Double, x As Integer Set sh = Sheets("a") With sh v = Val(.Range("D10").Value) / Val(.Range("G10").Value) For x = 1 To Val(.Range("G10").Value) .Cells(x + 12, 5) = v Next End With End Sub

مرحبا في غياب الملف هل جربت هذه الطريقة الكود يوضع في Workbook في حدث Workbook_SheetActivate Private Sub Workbook_SheetActivate(ByVal Sh As Object) ActiveSheet.Shapes.SelectAll Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter End Sub

جرب المرفق التالي 2ترحيل تذكرة.rar

ليس شرطا ان ترسل الملف ببياناته الاصلية مثلا تسمي الاعمدة : عمود1 - عمود2 - عمود3 . . . . . . الاسماء في الصفوف : اسم 1 اسم 2 اسم 3 و هكذا المهم بيانات وهمية

السلام عليكم الكود كان حسب الملف المرسل وان وقع خطأ فمعنى هذا ان الملف الذي تعمل عليه ربما يختلف في مواقع البيانات للملف المرسل

هذا الكود لاظافة ورقة عمل بشرط كتابة اسم المريض في الخلية D3 Sub Add_Sheets() Dim sh As Worksheet Sheets.Add After:=Sheets(Sheets.Count) Set sh = ActiveSheet With sh .Name = Sheets("الرئيسية").Range("D3") Sheets("الرئيسية").Columns("A:L").Copy .Range("A1") End With End Sub

العفو اخي زوهير

مرحبا بعد اذن اخي سليم انسخ التالي في الفورم Private Sub ComboBox1_Change() Set MyRange = ActiveSheet.Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row) On Error Resume Next X = MyRange.Cells.Find(ComboBox1, LookAt:=xlWhole, MatchCase:=True).Activate t2.Value = ActiveCell.Offset(, 8) End Sub Private Sub CommandButton1_Click() For i = 1 To 7 If Not Cells(ActiveCell.Row, i) = "" Then Cells(ActiveCell.Row, i + 1).Select r = r + 1 End If Next Cells(ActiveCell.Row, ActiveCell.Column) = "X" Cells(ActiveCell.Row, 9) = r t2.Value = r End Sub Private Sub UserForm_Initialize() t1.Value = "X" With Me.ComboBox1 .List = Sheets(1).Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row).Value End With End Sub

مرحبا هذه طريقة اسرع تتوافق مع الملف الذي ارسلته ضع هذا الكود في موديل و انشئ زر و اربطه بهذا الكود Sub RegroupValue() Range("L2:L" & Cells(Rows.Count, 12).End(3).Row).ClearContents Dim Rng, nCells, c, MyObject As Object, LR As Long Application.ScreenUpdating = False LR = ActiveSheet.UsedRange.Rows.Count Set MyObject = CreateObject("Scripting.Dictionary") Rng = Range("A1:i" & LR).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) Application.ScreenUpdating = True End Sub

يكون بهذه الطريقة Private Sub UserForm_Activate() Dim ws As Worksheet For Each ws In ThisWorkbook.Sheets If ws.Name <> "5" Then Me.ComboBox1.AddItem ws.Name Next End Sub

العفو هناك تعديل بسيط Private Sub CommandButton1_Click() Dim Rng As Range, M As Long, sh As Worksheet, last As Long Set sh = Sheets("حسابات") last = sh.Cells(sh.Rows.Count, 2).End(xlUp).Row Set Rng = sh.Range("b4:b" & last) If Not IsDate(TextBox1) Or TextBox1 = "" Then GoTo 100 On Error Resume Next M = Rng.Cells.Find(CDate(TextBox1), LookAt:=xlWhole, MatchCase:=True).Activate TextBox4.Value = sh.Range(ActiveCell.Address).Offset(, 8) 100 TextBox2.Value = WorksheetFunction.SumIf(sh.Range("a4:a" & last), 8, sh.Range("j4:j" & last)) End Sub هل اكتشفت موقع الخطأ جرب ان تترك مربع النص الخاص بالتاريخ فارغا في الكود الاول ستكتشف الخطأ السبب هو موقع السطر التالي If Not IsDate(TextBox1) Or TextBox1 = "" Then GoTo 100 يجب ان يكون بعد تعريف المتغيرين : sh و Last

مرحبا بعد اذن اخي ياسر ضع الكود التالي في زر Private Sub CommandButton1_Click() Dim Rng As Range, M As Long, sh As Worksheet, last As Long If Not IsDate(TextBox1) Or TextBox1 = "" Then GoTo 100 Set sh = Sheets("حسابات") last = sh.Cells(sh.Rows.Count, 2).End(xlUp).Row Set Rng = sh.Range("b4:b" & last) On Error Resume Next M = Rng.Cells.Find(CDate(TextBox1), LookAt:=xlWhole, MatchCase:=True).Activate TextBox4.Value = sh.Range(ActiveCell.Address).Offset(, 8) 100 TextBox2.Value = WorksheetFunction.SumIf(sh.Range("a4:a" & last), 8, sh.Range("j4:j" & last)) End Sub

مرحبا جرب هذا الكود في موديل و اجعل له زر Sub sCopyTo() Dim iSh As Worksheet, Sh As Worksheet, MyArray, MySheet, I As Long, R As Long, X As Long Dim Wrd1 As String, Wrd2 As String, Wrd3 As String Set iSh = Sheets("A"): Set Sh = Sheets("y") Wrd1 = "حول": Wrd2 = "معلق": Wrd3 = "معلقة" MyArray = iSh.Range("S10:AB" & iSh.Cells(Rows.Count, 21).End(xlUp).Row).Value ReDim MySheet(1 To UBound(MyArray, 1), 1 To UBound(MyArray, 2)) For I = LBound(MyArray, 1) To UBound(MyArray, 1) If MyArray(I, 1) <> Wrd1 And MyArray(I, 4) <> Wrd2 And MyArray(I, 4) <> Wrd3 Then For X = 3 To 10 MySheet(R + 1, X) = MyArray(I, X) Next X R = R + 1 End If Next I Sh.Range("A10").Resize(R, UBound(MySheet, 2)).Value = MySheet End Sub

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

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

جرب هذ الطريقة 22.rar

رغم انه لا يمكن الدخول في المنطقة التي يتواجد بها أخي سليم عندما يتعلق الامر بالدوال لكن جرب هذه الطريقة خفية قبل ان يكتشفنا 11.rar

lمرحبا اخي زياد أنشئ زرا و اكتب الكود التالي Private Sub CommandButton3_Click() Dim MyWorkbook As Workbook, wr As Worksheet, Last As Long Set wr = Sheets("حسابات") Application.ScreenUpdating = False: Application.DisplayAlerts = False Last = wr.Range("E" & Rows.Count).End(xlUp).Row If Last = 4 Then Exit Sub Set MyWorkbook = Workbooks.Add With MyWorkbook wr.Range("E4:G" & Last).Copy .Sheets(1).Range("A1") .ActiveSheet.DrawingObjects.Delete .SaveAs Filename:=ThisWorkbook.Path & "\" & Format(Date, "dd.MM.yy") & ".xlsx" .Close End With Application.ScreenUpdating = True End Sub

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

و كل عام و انتم و كل الامة الاسلامية بخير

تم عمل المطلوب 5555.rar

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