الـعيدروس

السلام عليكم هذا الكود في حدث الورقة في كل الملفات التسلسليه 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) T_A = Target.Offset(0, -1).Text .Activate Set S = .Sheets(1) S.Cells(S.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Row, 3) = T_A End With 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 خلينا نشمي حبه حبه اذا ملف main مغلق لاينفذ الكود اذا خلية D1 = 1 ينسخ خلية C1 الى ملف main في العمود C بعد اخر خليه بها بيانات * طيب متى ينفذ الشرط الاخر وهو حذف القيمة السابقة التي في ملف main * هل هو بمجرد كتابة رقم غير 1 يروح يحذف القيمة السابقة من ملف main للملف الحالي فرضا هو 1 ? * وهل مسموح التكرار قيمة من احد ملفات التسلسليه في ملف main ? ارجو الرد

طالما انت تريد تأخر من الكود مده معينه بأعتقادي فلا مشكله في التجميد دام هو في حدود الوقت المستقطع ان كان التجميد غير مستحب جرب هذا التعديل Private Const H_Scond As Single = 0.5 ' 0.25 ' 0.1667 Public Sub Tim_Ali() Dim A_T As Single A_T = Timer While Timer - A_T < H_Scond DoEvents Wend CopyPriceOver End Sub Private Sub CopyPriceOver() MsgBox "مرحباً", vbInformation, "منتدى أوفسينا" End Sub أو بإستخدام TimeSerial اعتقد هذا انسب لك Public R_A As Double Public Const Scond_A = 0.5 ' 0.25 ' 0.1667 Public Const Macro_ON = "O_M" Sub Star_A() R_A = Now + TimeSerial(0, 0, Scond_A) Application.OnTime EarliestTime:=R_A, Procedure:=Macro_ON, Schedule:=True End Sub Sub O_M() MsgBox "مرحباً", vbExclamation, "منتدى أوفسينا" End Sub

حسب معلوماتي النوع الذي في الشيت ليس لهو فورمات عملت كود تغير لون الخط والحجم للكمبوكس ولم يأثر بشيء Sub Shape_A() Dim Sh_A As Shape On Error Resume Next Set Sh_A = Sheet1.Shapes(1) With Sh_A.TextFrame .VerticalAlignment = xlVAlignCenter .AutoSize = True End With With Sh_A.Line .BackColor.RGB = RGB(25, 0, 0) .ForeColor.RGB = RGB(25, 255, 0) .Weight = 12 End With Sh_A.Fill.ForeColor.RGB = RGB(255, 255, 0) End Sub

السلام عليكم ان كنت اول مره تتعامل مع الاكواد في الاوفيس تبعك لاتنس تفعل اعدادات الماكرو من واجهة اعدادات الاكسل الى منخفض جدا شاهد المرفقات J.V1_A.rar

السلام عليكم الاخ الفاضل kalkol أرجو منك ارفاق مثال

السلام عليكم اخي الفاضل أبو ليمونه بالنسبة لدالة TimeValue غير دقيقة في وضع الثواني ولاكن بالامكان إستخدام Timer مع حلقة كالتالي غير وضع الثواني من أول الكود في الوضع العام الى أي جزء في الثانية Private Const H_Scond As Single = 0.5 ' 0.25 ' 0.1667 Private Const H_Scond As Single = 0.5 ' 0.25 ' 0.1667 Public Sub Tim_Ali() Dim A_T As Single A_T = Timer While Timer - A_T < H_Scond Wend CopyPriceOver End Sub Private Sub CopyPriceOver() MsgBox "مرحباً", vbInformation, "منتدى أوفسينا" End Sub

من اين تريد استخراج القيم الذي تريدها في كل المجموعات حسب فهمي جرب هذا الكود Public Sub Sum_Ali() Dim Sh As Worksheet Dim Rn As Range For Each Sh In ThisWorkbook.Worksheets For i = 13 To 48 Set R = Sh.Range(Sh.Cells(5, i), Sh.Cells(24, i)) Sh.Cells(25, i) = WorksheetFunction.Sum(R) Next i Next Sh End Sub

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

السلام عليكم اخي انس حاجب اذهب للمدويل وغير الامتداد كالتالي Public Function Ali_List(F_A As String, Optional Fltr_A As String = "*.xls") As Variant وكود حدث الورقة بيكون بهذا الشكل Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Target, Range("A:A")) Is Nothing Then S_F = ActiveCell.Text Path_A = ThisWorkbook.Path & "\" & S_F 'Path_A = "C:\A" ' اذا كان مسار Workbooks.Open Path_A 'Ali_Exec 0, "OPEN", Path_A & S_F, "", Path_A, 1 Cancel = True End If End Sub

السلام عليكم انا عمل عندي يظهر التاريخ مثل ماهو في الورقة جرب التعديل ربما يعمل عندك XXX_A1.rar

السلام عليكم إطلع على المرفق XXX_A.rar

عملت الكود حسب اتجاه البيانات الموضحه في المرفق تبعك وهكذا التعديل للعكس Public Sub Ali_Tr() Dim Sh As Worksheet Dim x, i Set Sh = ورقة1 x = 1 For i = 7 To Sh.Cells(Rows.Count, "K").End(xlUp).Row - 1 ' حلقة من الصف 7 حتى اخر خليه بها بيانات - صف With ActiveSheet ' x = يمثل الصفوف في الحلقه وهنا حطيناه يمثل أعمده حتى أخر الحلقة .Cells(2, x) = Sh.Cells(i, "K") End With x = x + 1 Next End Sub

السلام عليكم هذا الكود في حدث الورقة Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Target, Range("A:A")) Is Nothing Then Path_A = ThisWorkbook.Path & "\" S_F = ActiveCell.Text Ali_Exec 0, "OPEN", Path_A & S_F, "", Path_A, 1 Cancel = True End If End Sub وهذه الأكواد في مودويل Public Declare Function Ali_Exec Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Public 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_Imag() Dim Path_F$ Path_F = ThisWorkbook.Path M_v = Ali_List(Path_F) x = 2 If TypeName(M_v) <> "Boolean" Then For i = LBound(M_v) To UBound(M_v) Cells(x, 1) = M_v(i) x = x + 1 Next End If End Sub ستجد زر في المرفق بعد النقر عليه ستظهر اسماء الصور في العمود "A" أنقر مرتين على الصوره المراد فتحها هذه طريقة أفضل من الأرتباط التشعبي لان الارتباط التشعبي بطيء نوع ما أرجو أن هذه الطريقة تلبي الطلب Ali_Imag.rar

الاكواد المرتبطه بالكود الاساسي هي ثلاثه هذا الكود يحدد لزر المبيعات Public Sub Ali_Sale() ' 1 = مسار الملف المحدد أعلى الكود ' 2 = تحديد خلية التي بها رقم المستند ' 3 = حفظ الملف بأسم Nm_Work = " مبيعات" save_file Path_A, [I5], Nm_Work End Sub وهذا لزر المدفوعات Public Sub Ali_Payment() ' 1 = مسار الملف المحدد أعلى الكود ' 2 = تحديد خلية التي بها رقم المستند ' 3 = حفظ الملف بأسم Nm_Work = " مدفوعات" save_file Path_A1, [I5], Nm_Work End Sub وهذا لزر المقبوضات Public Sub Ali_Proceed() ' 1 = مسار الملف المحدد أعلى الكود ' 2 = تحديد خلية التي بها رقم المستند ' 3 = حفظ الملف بأسم Nm_Work = " مقبوضات" save_file Path_A2, [I5], Nm_Work End Sub وإن كان لكل واحد ملف فلابد من نسخ الاكود فرضا المبيعات بيكون كالتالي Public Nm_Work As String ' هنا تحددي مسار ملف المبيعات Private Const Path_A As String = "D:\المبيعات\فواتير\" Public Sub Ali_Sale() ' 1 = مسار الملف المحدد أعلى الكود ' 2 = تحديد خلية التي بها رقم المستند ' 3 = حفظ الملف بأسم Nm_Work = " مبيعات" save_file Path_A, [I5], Nm_Work End Sub Public Sub save_file(Path_x As String, m_r As Range, ByVal Fom_n As String) Dim full_path As String Dim aah As String Dim Ali_Num$ Dim Num% If ActiveSheet.CheckBox1.Value = True Then '*************************** Ali_Num = InputBox("إدخل عدد نسخ الطباعه", "منتدى أوفسينا") If Ali_Num = "False" Or Ali_Num = Cancel Then Exit Sub On Error Resume Next '*************************** For Num = 1 To Ali_Num Activewindow.SelectedSheets.PrintOut Next '*************************** Exit Sub Else GoTo 1 End If 1: If Range("i5") = "" Then MsgBox ("ادخل رقم الفاتوره") Exit Sub Else m = ActiveWorkbook.Name Workbooks.Add N = ActiveWorkbook.Name Windows(m).Activate ActiveSheet.Range("b1:j23").Copy Windows(N).Activate ActiveSheet.Range("b1:j23").Select ActiveSheet.Paste Range("b1:j23").Select Selection.Copy Range("b1:j23").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Columns("b:J").EntireColumn.AutoFit Range("b1").Select Application.CutCopyMode = False Application.DisplayAlerts = False If aah = [I5] & ".xls" Then MsgBox "الملف موجود بالفعل..." ActiveWorkbook.Close Application.DisplayAlerts = True Exit Sub Else '************************************************* ActiveWorkbook.SaveAs Filename:=Path_x & m_r & Fom_n '************************************************* Application.DisplayAlerts = True ActiveWorkbook.Close Application.DisplayAlerts = False ThisWorkbook.Save Application.DisplayAlerts = True End If End If End Sub وهكذا للمدفوعات Public Nm_Work As String Private Const Path_A1 As String = "D:\المبيعات\فواتير\مدفوعات الموردين\" Public Sub Ali_Payment() ' 1 = مسار الملف المحدد أعلى الكود ' 2 = تحديد خلية التي بها رقم المستند ' 3 = حفظ الملف بأسم Nm_Work = " مدفوعات" save_file Path_A1, [I5], Nm_Work End Sub Public Sub save_file(Path_x As String, m_r As Range, ByVal Fom_n As String) Dim full_path As String Dim aah As String Dim Ali_Num$ Dim Num% If ActiveSheet.CheckBox1.Value = True Then '*************************** Ali_Num = InputBox("إدخل عدد نسخ الطباعه", "منتدى أوفسينا") If Ali_Num = "False" Or Ali_Num = Cancel Then Exit Sub On Error Resume Next '*************************** For Num = 1 To Ali_Num Activewindow.SelectedSheets.PrintOut Next '*************************** Exit Sub Else GoTo 1 End If 1: If Range("i5") = "" Then MsgBox ("ادخل رقم الفاتوره") Exit Sub Else m = ActiveWorkbook.Name Workbooks.Add N = ActiveWorkbook.Name Windows(m).Activate ActiveSheet.Range("b1:j23").Copy Windows(N).Activate ActiveSheet.Range("b1:j23").Select ActiveSheet.Paste Range("b1:j23").Select Selection.Copy Range("b1:j23").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Columns("b:J").EntireColumn.AutoFit Range("b1").Select Application.CutCopyMode = False Application.DisplayAlerts = False If aah = [I5] & ".xls" Then MsgBox "الملف موجود بالفعل..." ActiveWorkbook.Close Application.DisplayAlerts = True Exit Sub Else '************************************************* ActiveWorkbook.SaveAs Filename:=Path_x & m_r & Fom_n '************************************************* Application.DisplayAlerts = True ActiveWorkbook.Close Application.DisplayAlerts = False ThisWorkbook.Save Application.DisplayAlerts = True End If End If End Sub وهكذا للمقبوضات Public Nm_Work As String Private Const Path_A2 As String = "D:\المبيعات\فواتير\مقبوضات العملاء\" Public Sub Ali_Proceed() ' 1 = مسار الملف المحدد أعلى الكود ' 2 = تحديد خلية التي بها رقم المستند ' 3 = حفظ الملف بأسم Nm_Work = " مقبوضات" save_file Path_A2, [I5], Nm_Work End Sub Public Sub save_file(Path_x As String, m_r As Range, ByVal Fom_n As String) Dim full_path As String Dim aah As String Dim Ali_Num$ Dim Num% If ActiveSheet.CheckBox1.Value = True Then '*************************** Ali_Num = InputBox("إدخل عدد نسخ الطباعه", "منتدى أوفسينا") If Ali_Num = "False" Or Ali_Num = Cancel Then Exit Sub On Error Resume Next '*************************** For Num = 1 To Ali_Num Activewindow.SelectedSheets.PrintOut Next '*************************** Exit Sub Else GoTo 1 End If 1: If Range("i5") = "" Then MsgBox ("ادخل رقم الفاتوره") Exit Sub Else m = ActiveWorkbook.Name Workbooks.Add N = ActiveWorkbook.Name Windows(m).Activate ActiveSheet.Range("b1:j23").Copy Windows(N).Activate ActiveSheet.Range("b1:j23").Select ActiveSheet.Paste Range("b1:j23").Select Selection.Copy Range("b1:j23").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Columns("b:J").EntireColumn.AutoFit Range("b1").Select Application.CutCopyMode = False Application.DisplayAlerts = False If aah = [I5] & ".xls" Then MsgBox "الملف موجود بالفعل..." ActiveWorkbook.Close Application.DisplayAlerts = True Exit Sub Else '************************************************* ActiveWorkbook.SaveAs Filename:=Path_x & m_r & Fom_n '************************************************* Application.DisplayAlerts = True ActiveWorkbook.Close Application.DisplayAlerts = False ThisWorkbook.Save Application.DisplayAlerts = True End If End If End Sub

الظاهر أنك حملتي المرفق وقت كنت اعدل لهذا الغرض سبحان الله ارجو منك تنزيل المرفق مره اخرى

السلام عليكم ماعليك سوى اضافة ليبلات وتوسعها مثل ماتريد تفضل اضفتها لك وغيرت المسميات acc - Copy_3.rar

السلام عليكم اخي الحبيب ابو الحسن صدقني حاولت مرتين ولم اهتدي إلى حل لان دالة Find صعب التحاور معها بحكم ثقلها لاكن أوعدك احاول إلى أن اصل الى حل أو اعمل كود اخر بفكره اخرى أرجو امهالي بعض الوقت والمشاركه مفتوحه للجميع إن سبقني أحد نوابغ المنتدى كان بها وإلا فعليك بالصبر إن الله مع الصابرين

السلام عليكم بارك الله فيك أستاذ بن عليه أنا ليس لي في المعادلات ولاكن عندما أشوف ردك أحب أن أستمتع بمشاهدة أعمالك لان فيها من الحرفيه وأتقان العمل تقبل مروري

السلام عليكم جربي هكذا عله يفي بالغرض '************************************************* Public Nm_Work As String ' هنا تحددي مسار ملف المبيعات Private Const Path_A As String = "D:\المبيعات\فواتير\" ' هنا تحددي مسار ملف المدفوعات 'انشئي مجلد بأسم ' مدفوعات الموردين Private Const Path_A1 As String = "D:\المبيعات\فواتير\مدفوعات الموردين\" ' هنا تحددي مسار ملف المقبوضات 'انشئي مجلد بأسم ' مقبوضات العملاء Private Const Path_A2 As String = "D:\المبيعات\فواتير\مقبوضات العملاء\" '************************************************* Public Sub Ali_Sale() ' 1 = مسار الملف المحدد أعلى الكود ' 2 = تحديد خلية التي بها رقم المستند ' 3 = حفظ الملف بأسم Nm_Work = " مبيعات" save_file Path_A, [I5], Nm_Work End Sub Public Sub Ali_Payment() ' 1 = مسار الملف المحدد أعلى الكود ' 2 = تحديد خلية التي بها رقم المستند ' 3 = حفظ الملف بأسم Nm_Work = " مدفوعات" save_file Path_A1, [I5], Nm_Work End Sub Public Sub Ali_Proceed() ' 1 = مسار الملف المحدد أعلى الكود ' 2 = تحديد خلية التي بها رقم المستند ' 3 = حفظ الملف بأسم Nm_Work = " مقبوضات" save_file Path_A2, [I5], Nm_Work End Sub Public Sub save_file(Path_x As String, m_r As Range, ByVal Fom_n As String) Dim full_path As String Dim aah As String Dim Ali_Num$ Dim Num% If ActiveSheet.CheckBox1.Value = True Then '*************************** Ali_Num = InputBox("إدخل عدد نسخ الطباعه", "منتدى أوفسينا") If Ali_Num = "False" Or Ali_Num = Cancel Then Exit Sub On Error Resume Next '*************************** For Num = 1 To Ali_Num Activewindow.SelectedSheets.PrintOut Next '*************************** Exit Sub Else GoTo 1 End If 1: If Range("i5") = "" Then MsgBox ("ادخل رقم الفاتوره") Exit Sub Else m = ActiveWorkbook.Name Workbooks.Add N = ActiveWorkbook.Name Windows(m).Activate ActiveSheet.Range("b1:j23").Copy Windows(N).Activate ActiveSheet.Range("b1:j23").Select ActiveSheet.Paste Range("b1:j23").Select Selection.Copy Range("b1:j23").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Columns("b:J").EntireColumn.AutoFit Range("b1").Select Application.CutCopyMode = False Application.DisplayAlerts = False If aah = [I5] & ".xls" Then MsgBox "الملف موجود بالفعل..." ActiveWorkbook.Close Application.DisplayAlerts = True Exit Sub Else '************************************************* ActiveWorkbook.SaveAs Filename:=Path_x & m_r & Fom_n '************************************************* Application.DisplayAlerts = True ActiveWorkbook.Close Application.DisplayAlerts = False ThisWorkbook.Save Application.DisplayAlerts = True End If End If End Sub فاتورة_A.rar

السلام عليكم طيب هكذا Private Sub CommandButton1_Click() With ورقة5 .UsedRange = "" For R = 1 To Sheets.Count LR = Sheets(R).Cells(Rows.Count, "B").End(xlUp).Row If Sheets(R).Name = "آخر قيمة" Then GoTo 0 Sheets(R).Cells(LR + 1, 2) = WorksheetFunction.Sum(Sheets(R).Range("B1:B" & LR)) 0: With .Cells(Rows.Count, "B").End(xlUp) E = .Row .Offset(1, 0) = Sheets(R).Name .Offset(1, 1) = Sheets(R).Range("B" & LR) End With Next .Cells(E + 1, 3) = WorksheetFunction.Sum(Range("C1:C" & E)) End With End Sub

اجرب ماتفضلت به أخي يوسف الان وإن شاء الله تزول هذه اللخبطه تحياتي لك

السلام عليكم كما أوردت في عنوان المشاركه ظهور حروف غريبه في بعض المشاركات هكذا ط§ظ„ط¹ظˆط¯ط© ط§ظ„ظ‰ أرجو من جائتها المشكله وتوصل إلى حل أن ينورنا بملاحظاته وشكرا

السلام عليكم بعد اذن الاخ الحبيب أبو حنين تفضل Private Sub CommandButton1_Click() With ورقة5 .UsedRange = "" For R = 1 To Sheets.Count LR = Sheets(R).Cells(Rows.Count, "B").End(xlUp).Row With .Cells(Rows.Count, "B").End(xlUp) E = .Row .Offset(1, 0) = Sheets(R).Name .Offset(1, 1) = Sheets(R).Range("B" & LR) End With Next .Cells(E + 1, 3) = WorksheetFunction.Sum(Range("C1:C" & E)) End With End Sub

السلام عليكم بعد اذن الاستاذ الحبيب أبو حنين تفضل Public Sub Ali_Tr() Dim Sh As Worksheet Dim x, i Set Sh = ورقة1 x = 1 For i = Sh.Cells(Rows.Count, "K").End(xlUp).Row - 1 To 7 Step -1 With ActiveSheet .Cells(2, x) = Sh.Cells(i, "K") End With x = x + 1 Next End Sub

الاخ الفاضل وليد أولا الرابط غير صحيح ثانيا أنت الان في منتدى الاكسل وليس الأكسس أرجو منك فتح موضوع في منتدى الأكسس **************************************************** أرجو من احد المشرفين نقل الموضوع إلى مكانه الصحيح ****************************************************