الـعيدروس

السلام عليكم ممكن أخي حسام أرجو منك أرفاق مثال ملف اكسل وبه أسماء الملفات ومسارها واذا كانت الملفات في نفس فولدرالملف نكتفي بأسمائها فقط

السلام عليكم الاخت الكريمة سالي اذهبي الى هذ السطر في الكود full_path = "D:\فواتير\المبيعات" 'ThisWorkbook.Path & "\" & [i5].Value & " مبيعات وأستبدليه بهذا full_path = "D:\فواتير\المبيعات" & "\" 'ThisWorkbook.Path & "\" & [i5].Value & " مبيعات" وخصوص تسمية الورقة بأسم الفاتور وأسم الورقة لم ارى اي سطر في الكود يقوم بما ذكرتيه ارجو ارفاق نسخه من ملفك ولو به بيانات خاصه اضفيفي بيانات وهميه وارفقيه وإن شاء الله سيتم عمل اللازم

السلام عليكم الكود كان يأخذ اخر صف به بيانات من العمود 4 الذي هو "D" استبدلنا 4 بـ 1 الذي هو عمود "A" عندما حذفت خلايا العمود D اصبح اخر صف هو الصف السابع لاكن عند الاعتماد على العمود A حيكون اخر صف يعتبر اخر صف للبيانات اذا سيتم تنفيذ الكود لكل الاعمده الى اخر صف موازي للصف الاخير لعمود A أرجو أن تكون أتضحت الصورة لديك تفضل جرب المرفق جمع_A.rar

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

السلام عليكم تفضل جمع الخلايا الملونة_A.rar

السلام عليكم تفضل اخي Sub Path_F() Dim My_Pass$ '********************************** My_Pass = "123" Sheets("إسم الورقة").Unprotect Password:=My_Pass ' '********************************** If ActiveSheet.CheckBox1.Value = True Then Activewindow.SelectedSheets.PrintOut Else GoTo 1 End If ''حفظ الفاتورة في ملف منفصل '1: If Range("i5") = "" Then MsgBox ("ادخل رقم الفاتورة") Exit Sub Else Dim full_path As String Dim aah As String m = ActiveWorkbook.Name '************************************* ' full_path = "D:\فواتير\المبيعات" 'ThisWorkbook.Path & "\" & [i5].Value & " مبيعات" ' '************************************* Debug.Print full_path Workbooks.Add N = ActiveWorkbook.Name Windows(m).Activate ActiveSheet.Range("b1:j11").Copy Windows(N).Activate ActiveSheet.Range("b1:j16").Select ActiveSheet.Paste Range("b1:j16").Select Selection.Copy Range("b1:j16").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:=full_path Application.DisplayAlerts = True ActiveWorkbook.Close Application.DisplayAlerts = False ThisWorkbook.Save Application.DisplayAlerts = True End If End If Sheets("إسم الورقة").Protect Password:=My_Pass End Sub

السلام عليكم حط هذا الكود في حدث الورقة Public Colr_Row As Range Private Sub Worksheet_Selectionchange(ByVal Target As Range) If Not Intersect(Target, Range("A2:M100")) Is Nothing Then On Error Resume Next If Not Colr_Row Is Nothing Then Colr_Row.EntireRow.Interior.ColorIndex = xlNone Colr_Row.EntireColumn.Interior.ColorIndex = xlNone End If '================================= ' من أول عمود في المدى إلى اخر عمود Range(Cells(Target.Row, 1), Cells(Target.Row, "M")).Interior.Color = RGB(245, 232, 168) Target.EntireColumn.Interior.Color = RGB(215, 228, 188) '================================= Application.EnableEvents = False Target.Interior.Color = RGB(255, 151, 168) Application.EnableEvents = True Set Colr_Row = Target End If End Sub

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

السلام عليكم جرب المرفق امل ان يكون المطلوب Classeur_A.rar

الاخ ابو تميم بارك الله فيه ولك بالمثل اضعاف مضاعفه تقبل تحياتي وشكري

السلام عليكم بيكون كالتالي Sub outsheet() MyWok = ActiveSheet.Name & ".xlsb" MYPATH = Environ("homedrive") & Environ("HOMEPATH") & "\desktop" & "\" & MyWok Dim Wok As Workbook For Each Wok In Workbooks If Wok.Name = MyWok Then ActiveSheet.Copy Before:=Workbooks(MyWok).Sheets(1) Application.Windows(2).Activate MsgBox ("تم نقل الملف إلى سطح المكتب"), vbMsgBoxRight, ("نقل ") Exit Sub End If Next If Dir(MYPATH) = "" Then ActiveSheet.Copy ActiveWorkbook.SaveAs Filename:=MYPATH, FileFormat:=xlExcel12, CreateBackup:=False Application.Windows(2).Activate MsgBox ("تم نقل الملف إلى سطح المكتب") Windows(MyWok).Close Else Application.DisplayAlerts = False If MsgBox(" هذا الملف موجود مسبقا هل تريد إستبداله ", vbYesNo, "الملف موجود مسبقا") = vbNo Then Exit Sub ActiveSheet.Copy ActiveWorkbook.SaveAs Filename:=MYPATH, FileFormat:=xlExcel12, CreateBackup:=False Application.Windows(2).Activate MsgBox ("تم إستبدال الملف ونقله إلى سطح المكتب ") Windows(MyWok).Close Application.DisplayAlerts = True Exit Sub End If End Sub

تفضل Public Sub ali_T() Dim r As Range, A, Ali_Path$ Dim T_A, T_B, S_A Str_A = "[Serv_" [B1].ColumnWidth = 69 Rt = 1 Ali_Path = "C:\Ali\gg.txt" '*************************************** ' C:\Ali\gg.txt المسار ' غيره حسب مسار ملف التكست والمسمى Open Ali_Path For Output As #1 '*************************************** With Application .ScreenUpdating = False .EnableEvents = False For Each r In Range("A1:A256") At = Replace(r.Text, "C:", "server=") If Not IsEmpty(r) Then A = Str_A & Rt & "]" & Chr(10) & At & Chr(10) T_A = Split(A, " ") T_B = Split(T_A(1), ".") S_A = T_A(0) & " " & T_B(0) & ":" & T_B(1) & "." & T_B(2) & ":" & T_A(2) & ":0:" & T_A(3) & ":" & T_A(4) Cells(Rt, 2) = S_A Print #1, Str_A & Rt & "]" & vbCrLf & S_A Rt = Rt + 1 End If Next .ScreenUpdating = True .EnableEvents = True End With Close #1 End Sub

السلام عليكم هذه داله معرفه وهيا كود الاستاذ الحبيب عبدالله باقشير وعليه تعديل طفيف تستخدم كالتالي 1 = فرضا المدى هو A2:A6 2 = فرضا خلية سمبل اللون هيا C1 =kh_SumCellColor(A2:A6;C1) اول معيار للداله المدى المراد جمع خلاياه والمعيار الثاني الخليه السمبل التي بها اللون المراد جمع الخلايا التي بنفس اللون Public Function kh_SumCellColor(my_r As Range, ByVal x As Range) As Integer Dim Cel As Range Dim v As Double ''''''''''''''''''''''''' For Each Cel In my_r If Cel.Interior.ColorIndex = x.Interior.ColorIndex Then v = v + Val(Cel) End If Next ''''''''''''''''''''''''' kh_SumCellColor = v End Function Kh_Sum_Color.rar

المشكلة الموقع يلزم اسم مستخدم وباسورد كي يتم الدخول لقائمة الاستعلام والعرض

السلام عليكم تفضل Sub A_vt() Dim Sh As Worksheet On Error Resume Next With ورقة5 .[A1].Columns.AutoFit .[A1] = "أخر قيم الأوراق" x = 2 For Each Sh In ThisWorkbook.Worksheets .Cells(x, 1) = Sh.UsedRange.Rows(UBound(Sh.UsedRange.Value)).Value x = x + 1 Next End With End Sub

السلام عليكم تفضل Sub A_Sum() Dim x As Double Dim Rn As Range For Each Rn In Range(Cells(7, 4), Cells(Cells(Rows.Count, 4).End(xlUp).Row, 4)) x = Val(Rn.Offset(0, -2)) + Val(Rn.Offset(0, -1)) xx = Val(Rn.Offset(0, 1)) + Val(Rn.Offset(0, 2)) xxx = Val(Rn.Offset(0, 4)) + Val(Rn.Offset(0, 5)) Rn.Value = x Rn.Offset(0, 3) = xx Rn.Offset(0, 6) = xxx If WorksheetFunction.CountIf(Range(Cells(Rn.Row, 2), Cells(Rn.Row, 10)), "غ") > 0 Then _ Rn.Offset(0, 7) = "غائب" Else Rn.Offset(0, 7) = WorksheetFunction.Sum(Cells(Rn.Row, 4), _ Cells(Rn.Row, 7), Cells(Rn.Row, 10)) Next End Sub

السلام عليكم Sub ScheduleCopyPriceOver() Application.Calculation = xlCalculationManual TimeToRun = Now + TimeValue("00:00:01") / 2 Application.OnTime TimeToRun, "CopyPriceOver" Application.Calculation = xlCalculationAutomatic End Sub

السلام عليكم لم افهم الطلب ارجو التوضيح اكثر عند البحث يحدد خلية البحث ويلونها باللون الاصفر وماهو اللون الاخضر الذي تقصده ؟ وبعد التحديد والتلوين لايقوم الكود بالرجوع للخليه مره ثانيه ؟ اعذرني لم افهم ارجو مزيد من التوضيح

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

السلام عليكم جرب هذا التعديل امل ان يكون المطلوب والسموحه منك سهيت عن موضوعك Public Sub ali_T() Dim r As Range, A, Ali_Path$ Dim T_A, T_B, S_A Str_A = "[Serv_" [B1].ColumnWidth = 69 Rt = 1 Ali_Path = "C:\Ali\gg.txt" '*************************************** ' C:\Ali\gg.txt المسار ' غيره حسب مسار ملف التكست والمسمى Open Ali_Path For Output As #1 '*************************************** With Application .ScreenUpdating = False .EnableEvents = False For Each r In Range("A1:A256") At = Replace(r.Text, "C:", "server=") If Not IsEmpty(r) Then A = Str_A & Rt & "]" & Chr(10) & At & Chr(10) T_A = Split(A, " ") T_B = Split(T_A(1), ".") S_A = T_A(0) & " " & T_B(0) & ":" & T_B(1) & "." & T_B(2) & ":" & T_A(2) & ":0:" & T_A(3) & ":" & T_A(4) Cells(Rt, 2) = S_A Print #1, Str_A & Rt & "]" & vbCrLf & S_A & vbCrLf Rt = Rt + 1 End If Next .ScreenUpdating = True .EnableEvents = True End With Close #1 End Sub

السلام عليكم جرب هذا التعديل Sub hh() Dim m As Range For Each m In Sheets("المشتريات").Range("F3:F1000") If m.Text Like Sheets("فاتورة مشتريات").Range("j3").Text Then MsgBox "رقم هذه الفاتورة موجود مسبقا", vbCritical, "خطأ" Exit Sub End If Next '---------------------------------------------------------------------------- Application.ScreenUpdating = False LR = Sheets("فاتورة مشتريات").Cells(Rows.Count, "Q").End(xlUp).Row LR1 = Sheets("المشتريات").Cells(Rows.Count, "E").End(xlUp).Offset(1, 0).Row With Sheet6 .Range(Cells(2, 17), Cells(A_S, 35)).Copy Sheets("المشتريات").Cells(LR1, 5).PasteSpecial xlPasteValues End With Application.ScreenUpdating = True: Application.CutCopyMode = False MsgBox "تم ترحيل البيانات بنجاح", vbInformation, "ترحيل" '-------------------------------------------------------------------------------------- For i = Sheets("المشتريات").Range("F" & Rows.Count).End(xlUp).Row To 1 Step -1 If WorksheetFunction.CountIf(Sheets("المشتريات").Range("F1:F" & i), Sheets("المشتريات").Range("F" & i).Value) > 1 Then Sheets("المشتريات").Range("F" & i) = "" End If Next i Sheets("فاتورة مشتريات").Select End Sub Public Function A_S() As Long Dim X, LR, R LR = Sheets("فاتورة مشتريات").Cells(Rows.Count, "Q").End(xlUp).Row With Sheet6 With .Range(.Cells(2, 17).Address, .Cells(LR, 17).Address) For R = 1 To .Rows.Count If IsDate(.Cells(R, 1)) Then X = .Cells(R, 1).Row End If Next End With End With A_S = X End Function

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

السلام عليكم الاستاذ الحبيب ابو حنين حفظك الله اعجبني هذا العمل جزاك الله كل خير واحببت أن اضيف اضافة بسيطه وهذا بعد اذنك أن الشكل ينشاء اتومتيك هذه الأكواد في مودويل Public Sh_A As Shape Sub Ali_Add() Dim A Dim B Dim C Set A = ThisWorkbook.VBProject Set C = A.VBComponents.Item("My_C").CodeModule C.AddFromString ("Sub Sh_Addres" & vbCrLf & "dim S$" & vbCrLf & "S = ""Ali_Sh"" " & vbCrLf & "Set Sh_A = ActiveSheet.Shapes(S)" & vbCrLf _ & "MsgBox "" أنا الآن في الصف رقم : "" & Sh_A.TopLeftCell.Row & "" العمود رقم : "" & activeCell.Column " & vbCrLf _ & " set Sh_A = nothing " & vbCrLf & "End Sub") End Sub Sub Ali_M() Set V_A = ActiveWorkbook.VBProject Set V_b = V_A.VBComponents.Add(vbext_ct_StdModule) V_b.Name = "My_C" End Sub Sub Ali_Delet() On Error Resume Next Dim V_A Dim V_b Set V_A = ActiveWorkbook.VBProject Set V_b = V_A.VBComponents("My_C") ActiveWorkbook.VBProject.VBComponents.Remove V_b End Sub وهذا كودك وعليه تعديل بسيط " كود حدث الورقة " Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) With Target With ActiveSheet On Error Resume Next .Shapes("Ali_Sh").Delete End With Set Sh_A = ورقة1.Shapes.AddShape(msoShapeActionButtonend, .Left, .Top, .Width, .Height) With Sh_A .TextFrame.HorizontalAlignment = xlHAlignCenter .TextFrame2.TextRange.Text = "أين موقعي" .Name = "Ali_Sh" MsgBox " الصف :" & .TopLeftCell.Row & " العمود :" & Target.Column Call Ali_Delet Call Ali_M Call Ali_Add .OnAction = "Sh_Addres" End With End With Cancel = True End Sub تحديد موقع_A.rar

السلام عليكم جرب هكذا حسب فهمي من المرفق ومرفق الاستاذ القدير ابو حنين اكتب اي قيمة في عمود A Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)) Is Nothing Then With Target .Offset(0, 1) = .Value + 2 .Offset(0, 2) = .Value + 5 .Offset(0, 3) = .Value + 8 End With End If End Sub او هذا الكود في مودويل Sub Ali_Fla() A_L = Columns(1).Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Offset(1, 0).Row With Cells(A_L, 1) .Offset(0, 1).FormulaR1C1 = .Offset(-1, 1).FormulaR1C1 .Offset(0, 2).FormulaR1C1 = .Offset(-1, 2).FormulaR1C1 .Offset(0, 3).FormulaR1C1 = .Offset(-1, 3).FormulaR1C1 End With End Sub DD_V.rar

السلام عليكم الاخ الفاضل abouelhassan استبدل الكود الذي في المودويل بالكود التالي وأي تعديل او اضافه انا موجود Public Sub Ali_Se(My_R As Range, ByVal S_A As String) Dim Rt As Range Dim F_A As String Dim B_A As Boolean Set Rt = My_R If Trim(S_A) = "" Then Exit Sub End If With ActiveSheet.Columns(7) Set Rt = .Find(S_A, [G1]) If Not Rt Is Nothing Then F_A = Rt.Address Do Application.Goto Rt, False With Range(Rt.Address) .Select .Interior.Color = 65535 End With If MsgBox("... انقر فوق نعم للبحث عن السجل التالي ، أو لا لوقف البحث ", vbYesNo + vbQuestion, "القيم المطابقة?") <> vbYes Then B_A = True With Range(Rt.Address) .Select .Interior.Color = 65535 .AddComment Text:="نتيجة البحث في هذا الخليه" .Comment.Visible = True End With Exit Do Else With Range(Rt.Address) .ClearComments .Interior.Color = xlNone End With End If Set Rt = .FindNext(Rt) Loop While (Rt.Address <> F_A) And Not (Rt Is Nothing) If Not B_A Then MsgBox "لاتوجد قيم اخرى مشابهه لـ " & S_A, vbInformation, "بحث" With Range(Rt.Address) .Select .Interior.Color = 65535 .AddComment Text:="نتيجة البحث في هذا الخليه" .Comment.Visible = True End With End If Else MsgBox S_A & " لاتوجد قيم مشابهه للبحث...", vbExclamation, "بحث" End If End With End Sub A_3.rar