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

بعد  اذن  استاذنا  الكبير  سليم تفضل  اخي   هذا  بالكود    

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

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