عبدالفتاح في بي اكسيل

اخي علي مشكلتك الاولى تم حلها اما الثانية فلم افهما البحث عندك ديناميكي من خلال الكود ولديك في صفحة DATE فوق 600 صف يبحث بشكل طبيعي وقمت بتجربته باضافة صفوف واشتغل عادي هناك ملاحظة لا تسمي ورقة البيانات باسم DATE لانه هذا الاسم يتعامل الكود معه على انه تاريخ وليس اسم ورقة عمل لا تختار اسماء خاصة بالبرمجة والا الكود سيحدث فيه اخطاء جرب الملف واعلمني rr.xlsm

بعد اذن استاذنا الكبير سليم تفضل اخي هذا بالكود Sub nn() Dim StartDate As Date Dim EndDate As Date Dim NoDays As Integer StartDate = Range("e1").Value EndDate = Range("g1").Value NoDays = EndDate - StartDate + 1 sheet1.Range("A1").CurrentRegion.Clear If StartDate > EndDate Then MsgBox "لا يمكن ان يكون تاريخ النهاية اقل من تاريخ البداية " Exit Sub End If Range("A1").Value = StartDate Range("A1").Resize(NoDays).DataSeries Rowcol:=xlColumns, Type:=xlChronological, Date:= _ xlDay, Step:=1, Stop:=EndDate, Trend:=False End Sub كتابة الفترة اوتوماتيك.xls

اخي ابو يزن عليك العمل اكثر وتوضيح ما هو بالضبط ووضع تصور بيانات والنتائج التي تريدها انا عن نفسي لم افهم شيء

اخي مطمئن عليك بطرح موضوع جديد بناء على العنوان وطلبك قمنا بحل المشكلة طرح موضوع جديد يسهل عليك وعلى الاساتدة للتفاعل معك تحياتي

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

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

تفضل هذا الكود ان شاء الله سيعمل Private Sub CommandButton1_Click() Dim Ary As Variant Dim i As Long, j As Long If Me.ListBox1.ListCount > 0 Then Ary = Application.Transpose(Me.ListBox1.List) ReDim Preserve Ary(LBound(Ary) To UBound(Ary), LBound(Ary, 2) To UBound(Ary, 2) + 1) Ary = Application.Transpose(Ary) Else ReDim Ary(1 To 1, 1 To 20) End If j = UBound(Ary) For i = LBound(Ary, 2) To UBound(Ary, 2) Ary(j, i) = Me.Controls("Textbox" & i).Value Next i Me.ListBox1.List = Ary End Sub

تفضل اخي مع هذا الماكرو البسيط لاتقم ثانية بدمج الخلايا لان الكود لايعمل ضع القيمة في الخلية g3 Sub abdelfattah() Dim NxtRw As Long On Error Resume Next NxtRw = Range("C5:C16").SpecialCells(xlBlanks)(1).Row On Error GoTo 0 If NxtRw = 0 Then Exit Sub Range("C" & NxtRw).Value = Range("G3").Value Range("G3").Value = "" End Sub Classeur STE (1).xls

تفضل اخي اتبع ما موجود في الصور ثم ضع هذا الكود تاكد من مسار الصورة حتى لايحدث خطا معك في الكود Private Sub UserForm_Initialize() Me.WebBrowser1.Navigate2 "C:\Download\1.gif" End Sub

صدقا انا اود مساعدتك لكن لا انصح بان يكون الليست بوكس به اكثر من 10 اعمدة سيكون البرنامج ثقيل ويبطيء من عمله وقد يتوقف يوجد طرق لكن ليست عملية وانا جربتها لانه على حد ما فهمت منك لديك بيانات كثيرة في ورقة العمل وبالتالي يجب ان تاخد هذا العامل بعين الاعتبار كلما كانت البيانات كثيرة في اوراق العمل قلت سرعة البرنامج لذا انا اقترح عليك تقسيم البيانات في اوراق العمل وايضا تقسيم الليست بوكس بتصميم اكثر من يوزرفورم عذرا على الاطالة ولكن اردت توضيح بعض النقاط جرب هذه الاكواد ل10 اعمدة فقط واذا كانت بياناتك اكثر من 10 اعمدة اعلمني لعلي اجد طريقة لذلك Private Sub CommandButton1_Click() Dim iX As Integer With Me.ListBox1 .AddItem For iX = 1 To 10 .List(.ListCount - 1, iX - 1) = Me("textbox" & iX).Value Next iX End With End Sub Private Sub CommandButton2_Click() Dim lRw As Long With æÑÞÉ1 lRw = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 .Cells(lRw, 1).Resize(Me.ListBox1.ListCount, Me.ListBox1.ColumnCount).Value = Me.ListBox1.List End With End Sub

على الرغم انك لم ترفق ملف لكن انظر الى هذا الملف لعلك تستفيد منه واعتقد انه المطلوب timer.xls

احسنت استاد سليم نفعنا الله بعلمك هذا المطلوب

شيء غريب استاد سليم لقد قمت بتنزيل ملفك وقمت بمسح بيانات الورقة 6 وقمت بتنفيد الماكرو وهذا ما ظهر كما في الصورة حت تعلم ما اريد عبارة عن عمليات محاسبية الورقة1=رصيد اول المدة والورقة الثانية مشتريات والورقة الثالثة مردودات مشتريات والورقة الرابعة مبيعات والورقة الخامسة مردودات مبيعات فبالتالي كما ذكرت في اول المشاركة تكون المعادلة في العمود d في الورقة السادسة كالتالي رصيد اول المدة +مشتريات -مردودات مشتريات -مبيعات +مردودات مبيعات

استاد سليم شكرا على محاولتك ولكن اصبح الكود لا يعمل ولا يكتب سوى كلمة balance في العمود d في الورقة 6

السلام عليكم الى خبراء الاكسيل احتاج الى تعديل الكود حيث الكود لا يعمل جيدا بالنسبة لعملية الجمع والطرح في العمود d لاوراق العمل 1و2و3و4و5 اما 6 فيظهر النتيجة النتيجة الموجود في الورقة 6 هي المفترض ان تكون عند الضغط على زر الماكرو اكثر من مرة يتم اظهار نتائج خاظئة بالاضافة انه يقوم بتكرار البيانات وهذا ما لاا اريده انا هنا اتحدث عن مشكلة الكود في العمود d حيث تتركز عمليات الجمع والطرح على سبيل المثال الكود aa1=250+120-50-50+50=320 Sub sumsub() Dim Ary As Variant Dim Dic As Object Dim i As Long Dim Cl As Range Set Dic = CreateObject("scripting.dictionary") Ary = Array("sheet1", "sheet2", "Sheet5", "sheet3", "sheet4") With Sheets(Ary(0)) .Range("A2:D" & .Range("A" & Rows.Count).End(xlUp).Row).Copy Sheets("Sheet6").Range("A" & Rows.Count).End(xlUp).Offset(1) End With With Sheets("Sheet6") For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp)) Dic.Item(Cl.Value) = Cl.Offset(, 3).Value Next Cl End With For i = 1 To UBound(Ary) With Sheets(Ary(i)) For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp)) If Dic.Exists(Cl.Value) Then Dic.Item(Cl.Value) = IIf(i < 3, Dic.Item(Cl.Value) + Cl.Offset(, 3), Dic.Item(Cl.Value) - Cl.Offset(, 3)) Next Cl End With Next i Sheets("Sheet6").Range("D2").Resize(Dic.Count).Value = Application.Transpose(Dic.items) End Sub _users And sheets.xlsm

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

تفضل اخي لعله المطلوب العالمي 2020.xlsm

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

جرب هذا الكود لعله المطلوب Sub Auto_Save() Application.DisplayAlerts = False Dim backupfolder As String backupfolder = "f:\Backup Excel Sheets \" ActiveWorkbook.SaveCopyAs Filename:=backupfolder & ActiveWorkbook.Name ActiveWorkbook.Save Application.DisplayAlerts = True MsgBox "Backup Run. Please Check at: " & backupfolder & " !" End Sub

اخي عامر تفضل لعله المطلوب لقد قمت بصياغة الملف وتسمية الاوراق بالانجليزي حتى يعمل الكود جيدا Sub copypaste() Dim lastrow As Integer, erow As Integer, sh1 As Worksheet, sh2 As Worksheet Set sh1 = Worksheets("sheet2") Set sh2 = Worksheets("sheet4") lastrow = sheet2.Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To lastrow erow = sheet4.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row sheet4.Cells(erow, 5) = sheet2.Cells(i, 1) sheet2.Cells(i, 1).ClearContents sheet4.Cells(erow, 3) = sheet2.Cells(i, 2) sheet2.Cells(i, 2).ClearContents sheet4.Cells(erow, 7) = sheet2.Cells(i, 5) sheet2.Cells(i, 5).ClearContents Next i ThisWorkbook.Worksheets("sheet4").Columns().AutoFit lastrow = sheet3.Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To lastrow erow = sheet4.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row sheet4.Cells(erow, 2) = sheet3.Cells(i, 1) sheet3.Cells(i, 1).ClearContents sheet4.Cells(erow, 4) = sheet3.Cells(i, 2).Formula sheet3.Cells(i, 2).ClearContents sheet4.Cells(erow, 6) = sheet3.Cells(i, 4) Next i ThisWorkbook.Worksheets("sheet4").Columns().AutoFit End Sub tarheel‬.xls

جرب هذا التعديل ()sub clear sheets("namesheet1").range("B2", "B13").clear sheets("namesheet2").range("h4","H16").clear sheets("namesheet3").range("h6", "h12").clear end sub

حسنا عذرا لاني اكثرت عليك الاسئلة ولكن كنت اريد ان اعرف لو لديك الملف الرئيسي لابد ان يعمل بالكامل وقد نعرف كيفية التعديل عليه لقد توصلت الى شيء واحد وهو ان المشكلة في الملف نفسه لاني عندما قلت لك قم بتعديل الكود كنت قد جربته على ملف اخر وقام بالترحيل دون اي مشاكل فعليك تصميم ملف آخر ولقد قمت بنسخ جميع الاكواد لان الازرار مرتبطة معا بعضها وسؤالي الاخير عن البحث لا يعمل هو لمعرفة اذا كان الخلل من التعديل الاخير ام من البرنامج يمكنك تجربة الملف طبعا بالانجليزي لاني طرحت موضوعك في مواقع اجنبية وبالكاد رد علي موقع 1 من اصل 3 SH.xlsm

هل لديك الملف الرئيس الذي اخدت منه الاكواد ام قمت تصميمه لوحدك

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

اخي مهند لقد حصلت على المساعدة من احد المبرمجين قم بتعديل هذا الكود واعلمني For c = 1 To ContColmn Ad = Cells(1, c).Address(0, 0) If Len(Trim(Me.Controls(Ad).Value)) = 0 Then MsgBox "address: " & Cells(1, c).Value & " empty", vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, "empty cells" Me.Controls(Ad).SetFocus Exit Sub End If Next