الـعيدروس

السطر الذي يصادفك عليه خطاء حط عليه علامة ' التي هيا حرف الطاء شوف الزر الذي تريد حذفه روح خذ اسمه اولاً قبل حذفه وخش على واجهة الاكواد اتبع الشرح في المرفق كي تتضح الصورة اكثر شرح11.rar

السلام عليكم شاهد الشرح بالمرفق شرح.rar

السلام عليكم اكتفي بحذف الازرار شيلها من علا الفورم

اخي الكريم marfipo كررت 4 مواضيع لطلب واحد ؟ جربت الكود مايقوم به بحذف التواريخ المكرره فقط ولا يحذف الاسطر الفارغه تجربتي.rar

السلام عليكم تفضل المرفق اولاً اختار نوع الاسرة التي تريد ثم شغل الفورم وضغط زر ترحيل البيانات تحياتي ترحيل أعمدة متفرقة_111.rar

ماهي الاعمدة التي تريد ترحيلها ؟

تفضل المرفق انقر الزر المسمى اجماليات في ورقة Total MD_111.rar

السلام عليكم تفضل تم التعديل البحث_222.rar

السلام عليكم تفضل جرب المرفق البحث_111.rar

السلام عليكم Private Sub CommandButton2_Click() Dim Sh As Worksheet Dim Sht As Worksheet Dim A As Variant Set Sh = Sheets("width") Set Sht = Sheets("result") A = Array("Width", "Samole") If Me.TextBox1 <> Empty Then Ali_F TextBox1, A(0), Sh If Me.TextBox2 <> Empty Then Ali_F TextBox2, A(1), Sht End Sub Public Function Ali_F(Tx, id, Tb As Worksheet) Dim Sht As Worksheet Dim Rng As Range Set Sht = Tb With Sht Set Rng = .Cells.Find(What:=id) If Not Rng Is Nothing Then Rng.Offset(, 1).Value = Tx End With End Function

السلام عليكم جرب الكود التالي Dim Arr(), x_r Public Sub Ali_Sm() Dim Sh As Worksheet Dim Sht As Worksheet Dim My_rn As Range Dim x, xx, Lr Dim Tabl_My() ''---------------------- Set Sht = Sheets("Total") ''--------------------------------------------------------------------------- For Each Sh In Sheets If IsNumeric(Trim(Sh.Name)) Then With Sh ReDim Preserve Tabl_My(1 To 10000, 1 To 2) For R = 8 To .Cells(.Rows.Count, 1).End(xlUp).Row If .Cells(R, 1) <> Empty Then xx = .Cells(R, 1).Row x = x + 1 Tabl_My(x, 1) = .Cells(xx, 1) Tabl_My(x, 2) = Application.Sum(.Range(.Cells(xx, 6), .Cells(xx, 36))) End If Next R End With End If Next Sh ''--------------------------------------------------------------------------- x_r = 0 ''-------------- Ali_Dicn Tabl_My ''-------------- If x_r Then With Sht ''================================================================= Lr = .UsedRange.Rows.Count Set My_rn = Range("B7:B" & IIf(Lr < 7, 7, Lr)) My_rn.ClearContents .Range("B7").Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr ''================================================================= End With Erase Arr: x_r = 0 End If Erase Tabl_My Set Sht = Nothing: Set My_rn = Nothing End Sub Private Function Ali_Dicn(Ar As Variant) Dim Idx As Object Dim U_C, i, D ''-------------------------------------------------- U_C = UBound(Ar, 2): U_R = UBound(Ar, 1) ReDim Arr(1 To U_R, 1 To U_C) Set Idx = CreateObject("Scripting.Dictionary") With Idx For i = 1 To U_R If Not IsEmpty(Ar(i, 1)) Then If Not .exists(Ar(i, 1)) Then x_r = x_r + 1 For D = 1 To U_C Arr(x_r, D) = Ar(i, D) Next D .Add Ar(i, 1), x_r ElseIf .exists(Ar(i, 1)) Then Arr(.Item(Ar(i, 1)), 2) = Arr(.Item(Ar(i, 1)), 2) + Ar(i, 2) End If End If Next i End With ''-------------------------------------------------- Set Idx = Nothing End Function

اعد تعين مدى الطباعه فقط اخرى الكود كالتالي Sub Clear_Sheet4_Data() Dim LastRow As Integer With Sheet4 LastRow = .Range("A" & Rows.Count).End(xlUp).Row .Range("A29:AY" & LastRow).Clear .Range("c8:x27").ClearContents '----------------------------------------------- .PageSetup.PrintArea = .Range("A1:Ay33").Address '----------------------------------------------- End With End Sub

الفكره بكل بساطه اول الكود تلغي باسورد الورقة كالتالي .Unprotect "باسورد الورقة" ونهاية الكود بعد ان نفذ الكود تعيد الحمايه للورقة كالتالي .Protect "باسورد الورقة"

السلام عليكم اذهب الى السطر التالي في الكود وحط باسورد حماية الورقة ''----------------------------- A = "" '' حط هنا باسورد حماية الورقة ''---------------------------- تفضل المرفق بعد ان تحط الباسورد جرب افتح الفورم تحياتي فورم ترحيل بشرط_333.rar

Public Sub Ali_A() If Evaluate("CountA(A:A)") = 38 Then Ali_S End Sub Private Function Ali_S() Dim Sh As Worksheet Dim Sht As Worksheet Dim Vl, a Set Sht = Sheets("data") '---------- Ap_Ali False '---------- If Sheets.Count = 1 Then a = 1 Else a = Val(Sheets(Sheets.Count).Name + 1) If IsError(Evaluate("'" & Nm & "'!A1")) Then Set Sh = ThisWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count)) With Sht .Range(.Cells(1, 1), .Cells(38, 8)).Copy Vl = CDbl(.Cells(38, 8)) With Sh .Name = a With .Range("A1") .PasteSpecial xlPasteValues .PasteSpecial xlPasteColumnWidths .PasteSpecial xlPasteFormats End With End With .[K1] = (.[K1] + Vl) If MsgBox("هل تريد مسح البيانات المرحله ؟", vbYesNo, "تأكيد مسح") = vbYes Then _ .Range("A2:H37").ClearContents .[A1].Select End With '---------- Ap_Ali True '---------- Set Sh = Nothing End If End Function Function Ap_Ali(Bll As Boolean) With Application .Calculation = IIf(Bll, -4105, -4135) .ScreenUpdating = Bll .EnableEvents = Bll End With End Function جرب الكود وهذا المرفق وبه الكود ترحيل الى اوراق متعددة_111.rar

الطلب غير واضح اخي الكريم حط مثال للنتيجه في الورقتين 1 و 2 كي نفهم الطلب

اذا امكن تعطيني نسخه من ملفاتك كما هيا فقط تمسح البيانات التي بها خصوصيه وتستبدلها بوهميه وارسلها على ايميلي وان شاء الله ازبط لك الكود كي يعمل على اكمل وجه Email : aahfm2015@gmail.com تحياتي

السلام عليكم اخي الكريم وائل الاسيوطي تفضل المرفق وبه طلبك + توضيح على اسطر الكود تحياتي فورم ترحيل بشرط_222.rar

السلام عليكم جرب المرفق فورم ترحيل بشرط_111.rar

اخي الحبيب ياسر فتحي اشكرك كثيرا على مرورك العطر والراقي دائماً

السلام عليكم اتبع الشرح في المرفق شرح-7.rar

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

اكيد ممكن تعديلات بسطيه على الاكواد وتعمل معاك ان شاء الله راجع الرابط التالي https://msdn.microsoft.com/en-us/library/ff700513(v=office.11).aspx لشركة مايكروسوفت كي تعرف التعديل على الاكواد لتعمل على نظام 64 بت تحياتي

لم تضع الشرط لدالة Split Public Function f(N) Dim S As String S = Split f = S End Function هكذا انت تركت الاداة بلا شغل ؟ لم تعطيها اي شيء عشان تعرف عمل الدالة او اي داله اخرى من دوال VBA تكتب اولاً VBA ثم دوت اي نقطة . ستظهر لك قائمة بدوال VBA انت طبعا بتكتب الدالة Split ثم تضغط علامة فتح قوس ( ستظهر لك معطيات الدالة التي تدرجها كي تعطيك مخرجات بمعنى "كي تقوم بعملها " ولاحظ المعطيات التي عليها [] اي هذا ليس اجباري مجرد اختياري ان اردت استخدامه اما الذي بدون الـ [] اجباري وان لم تكتبه ستعطيك الدالة رسالة خطأ ؟ الاول "Expression" القيمة التي تريد الدالة العمل عليها التي هيا "N" = الخلية الثاني "Delimiter" وهو الشرط الذي تريد الدالة تبحث عنه في السلسلة النصيه الذي هو " " المسافه الثالث "Limit As Long" اذا اعطيناه 0 سيعطيك الناتج كلمة "التاريخ" واذا اعطيناه 1 سيعطيك الناتج "215/12/03" عرفت عمل الشرط الثالث ايه ؟ اما الرابع "Compare" نستخدمه في حالة المقارنة بين سلسلة نصية لم نستخدمه في الذي نريد عمله ونلاحظ ان عليه [] اي اختياري وليس اجباري الخلاصه سيكون التعديل كالتالي S = VBA.Split(N, " ")(1) لتعطينى الناتج "2015/12/03"

السلام عليكم شاهد المرفق 222.rar