الـعيدروس

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

عذرا على هذا الخطاء ارجو تجربة الكود بعد التعديل اما خطاء الكود في التقاط الصور من الاسكنار لم تتضح المشكلة من وين عله يكون مشكلة المسار جرب الكود بعد التعديل Public Sub Ali_Imag() With Application .ScreenUpdating = False .EnableEvents = False Imp_Scan .EnableEvents = True .ScreenUpdating = True End With End Sub Private Sub Imp_Scan() Dim W_A As New WIA.ImageFile Dim WD_A As New WIA.CommonDialog Dim WS_A As WIA.Device Set WS_A = WD_A.ShowSelectDevice Dim Path_F$ Dim Ar As Variant Dim i, n, A_M Dim x(100) As Integer Dim Ar_Max& Dim Start%, Last%, Num% '************************** Path_F = "C:\" & "Ali" ' تعديل المسار من هذا السطر '************************** M_v = Ali_List(Path_F) If TypeName(M_v) <> "Boolean" Then For i = LBound(M_v) To UBound(M_v) M_v(i) = Ali_Re(M_v(i)) Next Start = LBound(M_v): Last = UBound(M_v) Num = Last - Start + 1 For i = Start To Last x(i) = M_v(i) Next i Ar_Max = x(Start) For n = Start + 1 To Last If x(n) > Ar_Max Then Ar_Max = x(n) Next n Else MsgBox "لاتوجد ملفات في المسار :" & Path_F End If With WS_A.Items(1) .Properties("6146").Value = 4 .Properties("6147").Value = 100 .Properties("6148").Value = 100 .Properties("6149").Value = 0 .Properties("6150").Value = 0 .Properties("6151").Value = 830 .Properties("6152").Value = 1167 Set W_A = .Transfer(wiaFormatJPEG) End With '************************************************************* If Ar_Max = 0 Then Ar_Max = 1 Else A_M = Ar_Max + 1 End If '************************** If Dir(Path_F & A_M & ".jpg") <> "" Then Kill Path_F & A_M & ".jpg" End If '************************** W_A.SaveFile (Path_F & A_M & ".jpg") '************************** Erase x Set W_A = Nothing Set WS_A = Nothing End Sub Private Function Ali_Re(R_N) As String R_N = Replace(R_N, ".jpg", "") R_N = Mid$(R_N, 1, 31) Ali_Re = R_N End Function Private Function Ali_List(F_A As String, Optional Fltr_A As String = "*.jpg") As Variant Dim Te_A As String, A_H As String If Right$(F_A, 1) <> "\" Then F_A = F_A & "\" Te_A = Dir(F_A & Fltr_A) If Te_A = "" Then Ali_List = False Exit Function End If Do A_H = Dir If A_H = "" Then Exit Do Te_A = Te_A & "|" & A_H Loop Ali_List = Split(Te_A, "|") End Function ومعك إن شاء الله إلى أن يعمل بشكل سليم تحياتي

السلام عليكم يوجد ارفق مثال اذا تكرمت تحياتي

السلام عليكم جرب هذا الكود مشكلة الكود البطئ يحتاج نصف دقيقة لترجمة نص والسبب الموقع الذي نأخذ الترجمة منه اذا وجدت موقع اخر ترجمتة حسب النصوص اسرع منه ارفقه وإن اشاء الله اعدل لك الكود لما يتناسب معه Public Sub Ali_Trn() On Error Resume Next Dim Ar Dim S_A$ [C2] = "يرجـــا الإنتظـــار" S_A = [A2].Text If S_A = "" Then MsgBox "خلية النص المراد ترجمته فارغه", vbExclamation, "تنبية !!!": Exit Sub Ar = Ali_HT(S_A) For Each Num In Array("[", "]") Ar = Replace(Ar, Num, "") Next [B2].Value = Ar [C2] = "تم الترجمــة" Application.Wait (Now + TimeValue("0:00:5")) [C2] = "" End Sub Public Function Ali_HT(Te_A As String) As String Dim A_T As Object Set A_T = CreateObject("InternetExplorer.application") A_T.navigate "http://www.worldlingo.com/en/products_services/worldlingo_translator.html" A_T.Visible = True Wait_A A_T A_T.document.all("wl_text").Value = Te_A A_T.document.all("wl_srclang").selectedIndex = 8 A_T.document.all("wl_trglang").selectedIndex = 0 A_T.document.all("Submit").Click Application.Wait (Now + TimeValue("0:00:20")) Wait_A A_T Ali_HT = A_T.document.all("wl_text_result").outerText A_T.Quit End Function Function Wait_A(A_T) Do Until A_T.ReadyState = 4 DoEvents Loop End Function تحياتي ترجمة_ASs.rar

السلام عليكم جزاك الله كل خير اخي أبو حنين ولإثراء الموضوع Sub Ali_D() Set R = Range("B2:B21") For Each Rn In R If IsDate(Rn) Then Rn.Value = Rn.Value2 Next End Sub

السلام عليكم اخي أبو تميم جرب هذا التعديل Public Sub Ali_Imag() With Application .ScreenUpdating = False .EnableEvents = False Imp_Scan .EnableEvents = True .ScreenUpdating = True End With End Sub Private Sub Imp_Scan() Dim W_A As New WIA.ImageFile Dim WD_A As New WIA.CommonDialog Dim WS_A As WIA.Device Set WS_A = WD_A.ShowSelectDevice Dim Path_F$ Dim Ar As Variant Dim i, n, A_M Dim x(100) As Integer Dim Ar_Max& Dim Start%, Last%, Num% Path_F = "C:\" & "Ali" M_v = Ali_List(Path_F) If TypeName(M_v) <> "Boolean" Then For i = LBound(M_v) To UBound(M_v) M_v(i) = Ali_Re(M_v(i)) Next Start = LBound(M_v): Last = UBound(M_v) Num = Last - Start + 1 For i = Start To Last x(i) = M_v(i) Next i Ar_Max = x(Start) For n = Start + 1 To Last If x(n) > Ar_Max Then Ar_Max = x(n) Next n Else MsgBox "لاتوجد ملفات في المسار :" & Path_F End If With WS_A.Items(1) .Properties("6146").Value = 4 .Properties("6147").Value = 100 .Properties("6148").Value = 100 .Properties("6149").Value = 0 .Properties("6150").Value = 0 .Properties("6151").Value = 830 .Properties("6152").Value = 1167 Set W_A = .Transfer(wiaFormatJPEG) End With '************************************************************* If Ar_Max = 0 Then Ar_Max = 1 Else A_M = Ar_Max + 1 End If If Dir(ThisWorkbook.Path & "\A_M.jpg") <> "" Then Kill ThisWorkbook.Path & "\A_M.jpg" End If '************************************************************** W_A.SaveFile (ThisWorkbook.Path & "\A_M.jpg") Erase x Set W_A = Nothing Set WS_A = Nothing End Sub Private Function Ali_Re(R_N) As String R_N = Replace(R_N, ".jpg", "") R_N = Mid$(R_N, 1, 31) Ali_Re = R_N End Function Private Function Ali_List(F_A As String, Optional Fltr_A As String = "*.jpg") As Variant Dim Te_A As String, A_H As String If Right$(F_A, 1) <> "\" Then F_A = F_A & "\" Te_A = Dir(F_A & Fltr_A) If Te_A = "" Then Ali_List = False Exit Function End If Do A_H = Dir If A_H = "" Then Exit Do Te_A = Te_A & "|" & A_H Loop Ali_List = Split(Te_A, "|") End Function الاخ الفاضل astika اتبع شرح مشاركة رقم 3#

السلام عليكم جرب هذا الكود Public Sub A_Hid() Dim C_Hid As Range On Error Resume Next Application.DisplayAlerts = False Set C_Hid = Application.InputBox(Prompt:="اختار العمود المراد اخفاءه ", Title:="تحديد عمود", Type:=8) On Error GoTo 0 If C_Hid Is Nothing Then Exit Sub Else Mg = MsgBox("للإخفاء نعم وللإظهار لا", vbYesNo, "تنبية !!!") If Mg = vbYes Then C_Hid.EntireColumn.Hidden = True Else C_Hid.EntireColumn.Hidden = False End If End If Application.DisplayAlerts = True End Sub

السلام عليكم اخي ابو تميم فرضا المسار هو C: في المجلد المسمى A حيكون التعديل في الكود هكذا If Dir("C:\A" & "\" & "My_Img.jpg") <> "" Then Kill "C:\A" & "\" & "My_Img.jpg" End If ************************************************************** W_A.SaveFile ("C:\A" & "\" & "My_Img.jpg") نعم في حال نقل الى جهاز اخر واذا المكتبة غير موجودة في Referenecs لابد من إضافتها مثل الشرح السابق وماذا تقصد بأكبر رقم هل تقصد بمسمى المجلدات مثلا في الـ C: يبحث عن مسميات المجلدات الاكبر اذا المجلدت مسمى رقمي ؟؟؟

الاخ الاستاذ الحبيب أبو حنين اشكرك على التشجيع والمرور الكريم جزاك الله كل خير الاخ الفاضل ايهاب سعيد ماذ تقصد بعنواين الصفوف حسب مافهمت جرب التعديل التالي مجاميع الصفحات حسب عناوين الصفوف في العمود A التي باللون الاحمر في معاينة الطباعه '**************************************** ' بداية البيانات بدون رؤس الأعمدة Private Const Row_Star As Integer = 2 '**************************************** 'الاعمدة المراد جمع قيمها في نهاية فواصل الصفحات Private Const C_N As String = "$B$1,$C$1,$D$1:$F$1" Sub Ali_Sum_Page() Dim Ar() As Integer Dim Rng As Range, Cc As Range Dim C As Range, Cr As Range Dim iCont As Integer Dim Arc As Variant Dim P_c Dim i As Integer, ii As Integer Dim r1 As Integer, r2 As Integer Dim Cv As Integer, L_C As Integer ''''''''''''''''''' On Error Resume Next Arc = Range(C_N).Address(0, 0) P_c = Range(Mid(Arc, 1, 2)).Column For Each Cc In Range(C_N) L_C = Cc.Column Next With Cells.Worksheet With .PageSetup .PrintTitleRows = "$1:$1" .PrintTitleColumns = "" End With .ResetAllPageBreaks .Range("A65536").Select .Cells(Row_Star, "A").Select iCont = .HPageBreaks.Count If iCont = 0 Then Exit Sub ''''''''''''''''''''''' ReDim Ar(1 To iCont) For i = 1 To .HPageBreaks.Count ii = .HPageBreaks(i).Location.row Ar(i) = ii Next ''''''''''''''''''''''' r1 = Row_Star For i = 1 To iCont ii = Ar(i) - 1 With .Cells(ii, P_c).Resize(1, L_C) .EntireRow.Insert With .Offset(-1, 0) L_r = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).row If Rng Is Nothing Then Set Rng = .Cells Else Set Rng = Union(Rng, .Cells) r2 = ii - 1 For Each C In Range(C_N) Cv = C.Column .Cells(1, Cv) = WorksheetFunction.Sum(Range(Cells(r1, Cv), Cells(r2, Cv))) With Cells(.row, 1) .Value = WorksheetFunction.CountA(Range(Cells(r1, Cv), Cells(r2, Cv))) .Interior.Color = RGB(255, 0, 0) End With Next r1 = r2 + 2 End With End With Next For Each Cr In Range(C_N) Cv = Cr.Column With .Cells(L_r, Cv) .Value = WorksheetFunction.Sum(Range(Cells(r1, Cv), Cells(L_r - 1, Cv))) With Cells(L_r, 1) .Value = WorksheetFunction.CountA(Range(Cells(r1, Cv), Cells(L_r - 1, Cv))) .Interior.Color = RGB(255, 0, 0) End With .Interior.ColorIndex = 6 End With Next End With '''''''''''''''''''''' If Not Rng Is Nothing Then With Rng .Interior.ColorIndex = 6 .Worksheet.PrintPreview Range("A" & L_r).EntireRow.Delete .EntireRow.Delete End With End If ''''''''''''''''''''''' Erase Ar Set Rng = Nothing: Set Cc = Nothing Set Cr = Nothing: Set C = Nothing End Sub Kh_Sum_Pages_A.rar

السلام عليكم أولا اذاهب الى محرر الأكواد قائمة Tools ثم Referenecs ثم انزله بالسكرول الى اسفل وحفز على الجمملة التالية Microsoft Windows Image Acquisition Library v2.0 واذا لم تجدها انقر على زر Browse في مربع النص File name : الصق السطر التالي ثم موافق C:\Windows\system32\wiaaut.dll بعد ادراج المكتبة بنجاح جرب الكود التالي Sub Imp_Scan() Dim W_A As New WIA.ImageFile Dim WD_A As New WIA.CommonDialog Dim WS_A As WIA.Device Set WS_A = WD_A.ShowSelectDevice With WS_A.Items(1) .Properties("6146").Value = 4 .Properties("6147").Value = 100 .Properties("6148").Value = 100 .Properties("6149").Value = 0 .Properties("6150").Value = 0 .Properties("6151").Value = 830 .Properties("6152").Value = 1167 Set W_A = .Transfer(wiaFormatJPEG) End With '************************************************************* If Dir(ThisWorkbook.Path & "\My_Img.jpg") <> "" Then Kill ThisWorkbook.Path & "\My_Img.jpg" End If '************************************************************** W_A.SaveFile (ThisWorkbook.Path & "\My_Img.jpg") Set W_A = Nothing Set WS_A = Nothing End Sub حفظ الصورة سيكون بنفس الفولدر بأسم My_Img ارجو تجربة الكود الكود من "msdn"

السلام عليكم تفضل Public Declare Sub Sleep Lib "kernel32" (ByVal A_Scound As Long) Public Sub Ali_API() DoEvents '1000 ' إنتظار ثانية ' 500 ' إنتظار نصف ثانية وهكذا Sleep (500) Ali_Time Exit Sub End Sub Private Sub Ali_Time() MsgBox "مرحباً", vbExclamation, "منتدى أوفسينا" End Sub

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

السلام عليكم الاخ الفاضل أبو تميم جرب هكذا '************************************ ' في ملف 1 Private Sub CommandButton2_Click() Dim Form_A As Workbook Path_A = ThisWorkbook.Path & "/" & "2.xlsb" Set Form_A = Workbooks.Open(Path_A) With Form_A .Activate Unload Me Application.Wait (Now + TimeValue("0:00:02")) Run "2.xlsb!Form2" End With End Sub '************************************ ' في ملف 2 Private Sub CommandButton2_Click() Dim Form_A As Workbook Path_A = ThisWorkbook.Path & "/" & "1.xlsb" Set Form_A = Workbooks.Open(Path_A) With Form_A .Activate Unload Me Application.Wait (Now + TimeValue("0:00:02")) Run "2.xlsb!form1" End With End Sub

السلام عليكم بعد اذن الاساتذة رجب جاويش و محمود رواس حل بطريقة اخرى كود حدث الورقة Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column <> 1 Or Target = "" Then Exit Sub Dim D_A Dim Tr_A$ Dim Cel As Range Set D_A = CreateObject("Scripting.dictionary") For Each Cel In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row - 1) If Not D_A.Exists(CStr(Cel.Value)) Then D_A.Add CStr(Cel.Value), CStr(Cel.Address) Next Cel Tr_A = Target.Value If D_A.Exists(Tr_A) Then If MsgBox(" هل تريد تكرار القيمة " & D_A.Item(Tr_A) & " : هذه القيمة موجوده مسبقا في الخلية ", _ vbYesNo, "تنبية !!!") = vbNo Then Target = "": Target.Select: Exit Sub End If End Sub

السلام عليكم الاخ الفاضل أبو ليله شكر لك على مورك الكريم الأستاذ العبقري والخلوق جدا عبدالله باقشير حفظك الله بالعكس استاذ عبدالله تعديلك من نصيب الأسد جزاك الله خير وبارك فيك وأطال الله بعمرك الاخ الفاضل astika إطلع على المرفقات Kh_Sum_Pages.rar

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

السلام عليكم اما عن طريق تنسيق خلايا ثم مخصص وتدرج هذا الرمز d" من شهر :"mmm" سنة :"yyyy او بالاعتماد على دالة تفقط معرف لااعلم لمن هيا هذا الكود في مودويل Sub Ali_Is_D() Dim R As Range Dim S, C Set R = [B5] S = Split(R.Text, "/") E = NoToTxt(Val(S(0)), "", "") ' السنه Ec = NoToTxt(Val(S(2)), "", "") 'اليوم [C5] = Ec & "من شهر :" & Format(R.Text, "MMM") & " سنة :" & E End Sub وهذه الداله المعرفه في مودويل Function NoToTxt(TheNo As Double, MyCur As String, MySubCur As String) As String Dim MyArry1(0 To 9) As String Dim MyArry2(0 To 9) As String Dim MyArry3(0 To 9) As String Dim Myno As String Dim GetNo As String Dim RdNo As String Dim My100 As String Dim My10 As String Dim My1 As String Dim My11 As String Dim My12 As String Dim GetTxt As String Dim Mybillion As String Dim MyMillion As String Dim MyThou As String Dim MyHun As String Dim MyFraction As String Dim MyAnd As String Dim i As Integer Dim ReMark As String If TheNo > 999999999999.99 Then Exit Function If TheNo < 0 Then TheNo = TheNo * -1 ReMark = " " Else ReMark = " " End If If TheNo = 0 Then NoToTxt = "" Exit Function End If MyAnd = " و" MyArry1(0) = "" MyArry1(1) = "مائة" MyArry1(2) = "مائتان" MyArry1(3) = "ثلاثمائة" MyArry1(4) = "أربعمائة" MyArry1(5) = "خمسمائة" MyArry1(6) = "ستمائة" MyArry1(7) = "سبعمائة" MyArry1(8) = "ثمانمائة" MyArry1(9) = "تسعمائة" MyArry2(0) = "" MyArry2(1) = " عشرة" MyArry2(2) = "عشرون" MyArry2(3) = "ثلاثون" MyArry2(4) = "أربعون" MyArry2(5) = "خمسون" MyArry2(6) = "ستون" MyArry2(7) = "سبعون" MyArry2(8) = "ثمانون" MyArry2(9) = "تسعون" MyArry3(0) = "" MyArry3(1) = "الأول" MyArry3(2) = "الثاني" MyArry3(3) = "الثالث" MyArry3(4) = "الرابع" MyArry3(5) = "الخامس" MyArry3(6) = "السادس" MyArry3(7) = "السابع" MyArry3(8) = "الثامن" MyArry3(9) = "التاسع" '====================== GetNo = Format(TheNo, "000000000000.00") i = 0 Do While i < 15 If i < 12 Then Myno = Mid$(GetNo, i + 1, 3) Else Myno = "0" + Mid$(GetNo, i + 2, 2) End If If (Mid$(Myno, 1, 3)) > 0 Then RdNo = Mid$(Myno, 1, 1) My100 = MyArry1(RdNo) RdNo = Mid$(Myno, 3, 1) My1 = MyArry3(RdNo) RdNo = Mid$(Myno, 2, 1) My10 = MyArry2(RdNo) If Mid$(Myno, 2, 2) = 11 Then My11 = "إحد عشر" If Mid$(Myno, 2, 2) = 12 Then My12 = "اثنا عشر" If Mid$(Myno, 2, 2) = 10 Then My10 = "عشرة" If ((Mid$(Myno, 1, 1)) > 0) And ((Mid$(Myno, 2, 2)) > 0) Then My100 = My100 + MyAnd If ((Mid$(Myno, 3, 1)) > 0) And ((Mid$(Myno, 2, 1)) > 1) Then My1 = My1 + MyAnd GetTxt = My100 + My1 + My10 If ((Mid$(Myno, 3, 1)) = 1) And ((Mid$(Myno, 2, 1)) = 1) Then GetTxt = My100 + My11 If ((Mid$(Myno, 1, 1)) = 0) Then GetTxt = My11 End If If ((Mid$(Myno, 3, 1)) = 2) And ((Mid$(Myno, 2, 1)) = 1) Then GetTxt = My100 + My12 If ((Mid$(Myno, 1, 1)) = 0) Then GetTxt = My12 End If If (i = 0) And (GetTxt <> "") Then If ((Mid$(Myno, 1, 3)) > 10) Then Mybillion = GetTxt + " مليار" Else Mybillion = GetTxt + " مليارات" If ((Mid$(Myno, 1, 3)) = 2) Then Mybillion = " مليار" If ((Mid$(Myno, 1, 3)) = 2) Then Mybillion = " ملياران" End If End If If (i = 3) And (GetTxt <> "") Then If ((Mid$(Myno, 1, 3)) > 10) Then MyMillion = GetTxt + " مليون" Else MyMillion = GetTxt + " ملايين" If ((Mid$(Myno, 1, 3)) = 1) Then MyMillion = " مليون" If ((Mid$(Myno, 1, 3)) = 2) Then MyMillion = " مليونان" End If End If If (i = 6) And (GetTxt <> "") Then If ((Mid$(Myno, 1, 3)) > 10) Then MyThou = GetTxt + " ألف" Else MyThou = GetTxt + " آلاف" If ((Mid$(Myno, 3, 1)) = 1) Then MyThou = " ألف" If ((Mid$(Myno, 3, 1)) = 2) Then MyThou = " ألفان" End If End If If (i = 9) And (GetTxt <> "") Then MyHun = GetTxt If (i = 12) And (GetTxt <> "") Then MyFraction = GetTxt End If i = i + 3 Loop If (Mybillion <> "") Then If (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then Mybillion = Mybillion + MyAnd End If If (MyMillion <> "") Then If (MyThou <> "") Or (MyHun <> "") Then MyMillion = MyMillion + MyAnd End If If (MyThou <> "") Then If (MyHun <> "") Then MyThou = MyThou + MyAnd End If If MyFraction <> "" Then If (Mybillion <> "") Or (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then NoToTxt = ReMark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur + MyAnd + MyFraction + " " + MySubCur Else NoToTxt = ReMark + MyFraction + " " + MySubCur End If Else NoToTxt = ReMark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur End If End Function

السلام عليكم هذا كود من أعمال الأستاذ الكبير عبدالله باقشير حفظه الله ورعاه أحببت أن اطرحه في موضوع كي يستفيد منه الجميع في أول الكود تحط الشروط المراده * بداية البيانات بدون رؤس الاعمدة * الاعمدة المراد عمل عليها جمع بالامكان تحديد الاعمده اما بشكل فردي وهو "$A$1,$C$1,$F$1" أو بشكل مدى من الى هكذا "$A$1:$G$1" أو بشكل مدى متقطع هكذا "$A$1,$C$1,$E$1:$H$1,$i$1:$K$1" ******************************************************************** الكود ينشاء صف وبه الجمع وبعد الانتهاء من وضع معاينة الطباعه يحذف الصف ******************************************************************** الكود يوضع في مودويل '**************************************** ' بداية البيانات بدون رؤس الأعمدة Private Const Row_Star As Integer = 2 '**************************************** 'الاعمدة المراد جمع قيمها في نهاية فواصل الصفحات Private Const C_N As String = "$A$1,$C$1,$D$1:$F$1" Sub Ali_Sum_Page() Dim Ar() As Integer Dim Rng As Range, Cc As Range Dim C As Range, Cr As Range Dim iCont As Integer Dim i As Integer, ii As Integer Dim r1 As Integer, r2 As Integer Dim Cv As Integer, L_C As Integer ''''''''''''''''''' For Each Cc In Range(C_N) L_C = Cc.Column Next With Cells.Worksheet With .PageSetup .PrintTitleRows = "$1:$1" .PrintTitleColumns = "" End With .ResetAllPageBreaks .Range("A65536").Select .Cells(Row_Star, "A").Select iCont = .HPageBreaks.Count If iCont = 0 Then Exit Sub ''''''''''''''''''''''' ReDim Ar(1 To iCont) For i = 1 To .HPageBreaks.Count ii = .HPageBreaks(i).Location.row Ar(i) = ii Next ''''''''''''''''''''''' r1 = Row_Star For i = 1 To iCont ii = Ar(i) - 1 With .Range("A" & ii).Resize(1, L_C) .EntireRow.Insert With .Offset(-1, 0) L_r = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).row If Rng Is Nothing Then Set Rng = .Cells Else Set Rng = Union(Rng, .Cells) r2 = ii - 1 For Each C In Range(C_N) Cv = C.Column .Cells(1, Cv) = WorksheetFunction.Sum(Range(Cells(r1, Cv), Cells(r2, Cv))) Next r1 = r2 + 2 End With End With Next For Each Cr In Range(C_N) Cv = Cr.Column With .Cells(L_r, Cv) .Value = WorksheetFunction.Sum(Range(Cells(r1, Cv), Cells(L_r - 1, Cv))) .Interior.ColorIndex = 6 End With Next End With '''''''''''''''''''''' If Not Rng Is Nothing Then With Rng .Interior.ColorIndex = 6 .Worksheet.PrintPreview Range("A" & L_r).EntireRow.Delete .EntireRow.Delete End With End If ''''''''''''''''''''''' Erase Ar Set Rng = Nothing: Set Cc = Nothing Set Cr = Nothing: Set C = Nothing End Sub والسلام عليكم

بتغير نوع المتغير بدلا من Single تحط String وإضافة علامتين التنصيص "$A$1" ليصبح كالتالي Private Const H_Scond As String = "$A$1" وهذا السطر : While Timer - A_T < H_Scond بدلا من H_Scond تحط Val(Range(H_Scond)) ليصبح الكود بعد التعديلات كالاتي Private Const H_Scond As String = "$A$1" ' Single = String ' A1 = "$A$1" Public Sub Tim_Ali() Dim A_T As Single A_T = Timer While Timer - A_T < Val(Range(H_Scond)) 'H_Scond = Val(Range(H_Scond)) DoEvents Wend CopyPriceOver End Sub Private Sub CopyPriceOver() MsgBox "مرحباً", vbInformation, "منتدى أوفسينا" End Sub

هذا الرقم كبير 5,380,235,202.47 من اين استخرجته اذا جمعت ارقام جمع الاعمدة A لن يساوي الرقم اعلاه ارجو التوضيح اكثر

السلام عليكم جرب هكذا موضح على الكود السطور الاختياريه الكود في مودويل Public Msg_a As String Public Function B_A(Str_B As String) As Boolean Dim Work As Workbook On Error Resume Next Set Work = Workbooks(Str_B) On Error GoTo 0 If Work Is Nothing Then B_A = False Else B_A = True End If End Function Public Sub Target_Ali() With Application .EnableEvents = False .ScreenUpdating = False .DisplayAlerts = False Dim خلية_الرقم As Range, خلية_المسار As Range Set خلية_الرقم = Range("N1") ' هذا يعبر عن خلية إدخال الرقم غيرها الى اي خليه تريدها Set خلية_المسار = Range("M1") ' هذا يعبر عن خلية مسار الملف غيرها الى اي خليه تريدها If Not خلية_الرقم Is Nothing Then Dim Str_B As String Dim T_A, C, A Str_B = "main.xls" If B_A(Str_B) Then If خلية_الرقم.Text = "" Then MsgBox " خلية الرقم فارغة :" & خلية_الرقم.Address, vbExclamation, "تنبية !!!": Exit Sub If خلية_الرقم.Value = 1 Then '*************************** If Ali_TQrar(خلية_المسار) = True Then ' A = GetSetting("Ali_A", "Ali_B", "Ali_C", (Msg_a)) ' MsgBox " هذه القيمة :" & " " & خلية_المسار.Text & vbNewLine & vbCrLf & " موجوده في ملف :" _ & Str_B & " " & vbNewLine & vbCrLf & " في الخلايا التالية :" & " " & A, vbInformation, "تنبية !!!" ' DeleteSetting "Ali_A", "Ali_B" ' Exit Sub End If '*************************** Dim s As Worksheet With Workbooks(Str_B) ' هذا التعبير عن ملف Main W_Name = ThisWorkbook.Name T_A = خلية_المسار.Text Set s = .Sheets(1) ' هنا رقم الورقة المراد لصق البيانات فيها في ملف Main L_A = s.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0).Row ' هنا اخذ اخر صف به بيانات + صف من عمود C للصق القيم المنسوخه s.Cells(L_A, "C") = T_A ' تسجيل قيمة خلية المسار عمود C بإمكانك تغيره لأي عمود s.Cells(L_A, "B") = W_Name ' تسجيل إسم ملف المنسوخ منه في عمود B .Save End With ElseIf خلية_الرقم.Value = 0 Then Call Ali_D End If Else MsgBox Str_B & " الملف مغلق", vbOKOnly + vbExclamation Exit Sub End If End If .DisplayAlerts = True .ScreenUpdating = True .EnableEvents = True End With End Sub Private Sub Ali_D() With Application .EnableEvents = False .ScreenUpdating = False .DisplayAlerts = False Dim Ar() As Variant Dim Wo As Workbook, T_W As Workbook Dim Sh As Worksheet Dim Str_B As String Dim R As Range Dim i, ii, C, M_r, Rw Str_B = "main.xls" Set Wo = Workbooks(Str_B) Set T_W = ThisWorkbook Wo.Activate Set Sh = Wo.Sheets(1) Set R = Sh.Range("C2:C1000") With R For i = 1 To .Rows.Count If Not .Cells(i, 1).Text = Empty And .Cells(i, 1).Text = T_W.Sheets(1).[C1] Then ReDim Preserve Ar(0 To C) Ar(C) = .Cells(i, 1).Address C = C + 1 End If Next If Len(C) > 0 Then For ii = LBound(Ar) To UBound(Ar) Rw = Rw + 1 M_r = M_r & "," & Ar(ii) Next Wo.Sheets(1).Range(Mid(M_r, 2, Len(M_r))).EntireRow.Delete Shift:=xlUp MsgBox "تم حذف القيمة المطابقة من ملف : " & Wo.Name & " " & " عدد الصفوف التي تم حذفها :" & Rw, vbExclamation, "تنبية !!!" Else MsgBox "لاتوجد قيمة مماثله في : " & Wo.Name, vbExclamation, "تنبية !!!" End If End With Erase Ar Wo.Save T_W.Activate .DisplayAlerts = True .ScreenUpdating = True .EnableEvents = True End With End Sub Public Function Ali_TQrar(خلية_المسار_A As Range) As Boolean With Application .EnableEvents = False .ScreenUpdating = False .DisplayAlerts = False Dim Max_r() As Variant Dim Wo As Workbook, T_W As Workbook Dim Sh As Worksheet Dim Msar_B As String, Msg_a As String Dim Va_Text As String Dim R As Range, Rc As Range Dim i, ii, Val_Ar, M_r, Rw Msar_B = "main.xls" Set Wo = Workbooks(Msar_B) Set T_W = ThisWorkbook Wo.Activate Set Sh = Wo.Sheets(1) 'رقم الورقة في ملف Main Set R = Sh.Range("C2:C1000") ' المدى المراد التحقق منه بياناته تحسبا للتكرار Set Rc = خلية_المسار_A Va_Text = Rc.Text ' خلية المسار في الملف التسلسلي With R For i = 1 To .Rows.Count If Not .Cells(i, 1).Text = Empty And .Cells(i, 1).Text = Va_Text Then ReDim Preserve Max_r(0 To Val_Ar) Max_r(Val_Ar) = .Cells(i, 1).Address Msg_a = Msg_a & vbCrLf & .Cells(i, 1).Address & vbCrLf Debug.Print Msg_a Val_Ar = Val_Ar + 1 End If Next '*********************************************** SaveSetting "Ali_A", "Ali_B", "Ali_C", (Msg_a) '*********************************************** If Len(Val_Ar) > 0 Then Ali_TQrar = True End With Erase Max_r T_W.Activate .DisplayAlerts = True .ScreenUpdating = True .EnableEvents = True End With End Function

ملفك مجرد ماافتحه تظهر رسالة ويعلق الملف ويغلق ؟

الحمد الله الذي بنعمته تتم الصالحات يارك الله فيك اخي ابو تميم على كلامك وشعورك الطيب الاخ الفاضلjo11 اشكرك على مرورك الكريم تقبلو تحياتي وشكري

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

السلام عليكم الاخ الحبيب ابو تميم هذا نفس الكود السابق وعليه اضافات بسطيه كود حدث الورقة في كل الملفات التسلسليه Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, [D1]) Is Nothing Then Dim Str_B As String Dim T_A Str_B = "main.xls" If B_A(Str_B) Then If Target.Value = 1 Then Dim s As Worksheet With Workbooks(Str_B) W_Name = ThisWorkbook.Name T_A = Target.Offset(0, -1).Text Set s = .Sheets(1) L_A = s.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Row s.Cells(L_A, 3) = T_A s.Cells(L_A, 2) = W_Name End With ElseIf Target.Value = 0 Then Call Ali_D End If Else MsgBox Str_B & " الملف مغلق", vbOKOnly + vbExclamation Exit Sub End If End If End Sub وهذه الأكواد في مودويل انسخها لكل الملفات Public Function B_A(Str_B As String) As Boolean Dim Work As Workbook On Error Resume Next Set Work = Workbooks(Str_B) On Error GoTo 0 If Work Is Nothing Then B_A = False Else B_A = True End If End Function Public Sub Ali_D() Dim Ar() As Variant Dim Wo As Workbook, T_W As Workbook Dim Sh As Worksheet Dim Str_B As String Dim R As Range Dim i, ii, C, M_r, Rw Str_B = "main.xls" Set Wo = Workbooks(Str_B) Set T_W = ThisWorkbook Wo.Activate Set Sh = Wo.Sheets(1) Set R = Sh.Range("C2:C1000") With R For i = 1 To .Rows.Count If Not .Cells(i, 1).Text = Empty And .Cells(i, 1).Text = T_W.Sheets(1).[C1] Then ReDim Preserve Ar(0 To C) Ar(C) = .Cells(i, 1).Address C = C + 1 End If Next If Len(C) > 0 Then For ii = LBound(Ar) To UBound(Ar) Rw = Rw + 1 M_r = M_r & "," & Ar(ii) Next Wo.Sheets(1).Range(Mid(M_r, 2, Len(M_r))).EntireRow.Delete Shift:=xlUp MsgBox "تم حذف القيمة المطابقة من ملف : " & Wo.Name & " " & " عدد الصفوف التي تم حذفها :" & Rw, vbExclamation, "تنبية !!!" Else MsgBox "لاتوجد قيمة مماثله في : " & Wo.Name, vbExclamation, "تنبية !!!" End If End With Erase Ar T_W.Activate End Sub ارجو تجربة الأكواد دمت في حفظ الله