الـعيدروس

Private Const D = 4 Private Const K = 16 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$G$2" Then If Target = "" Then Exit Sub Range("C6:K50").ClearContents hhhhh Target, 1: hhhhh Target, 2 End If End Sub Private Function hhhhh(Trget, i) Dim Ws As Worksheet Set Ws = Sheets("inv") Col = IIf(i = 1, 3, 9): Cl = IIf(i = 1, D, K): L = IIf(i = 1, 4, 3) For R = 2 To Ws.Cells(Rows.Count, Cl).End(xlUp).Row If Trim(Ws.Cells(R, Cl)) Like Trim(Trget) Then Lr = Cells(Rows.Count, Col).End(xlUp).Row For C = 1 To L Cells(Lr + 1, IIf(i = 1, Choose(C, 3, 4, 5, 6), Choose(C, 9, 10, 11))) = _ Ws.Cells(R, IIf(i = 1, Choose(C, 2, 3, 5, 6), Choose(C, 14, 15, 17))) Next C End If Next R End Function

شاهد المرفق كي تفهم مااقصد اليوم_111.rar

السلام عليكم الكود الذي في ملفك استبدله بالتالي بعد التعديل عليه Sub Macro1() Dim WB As Workbook, myRng As Range, Cell As Range Dim myRow As Long, lCol As Long Dim shMain As Worksheet Dim Sh As Worksheet Application.ScreenUpdating = False Application.EnableEvents = True Application.DisplayAlerts = False Set shMain = ThisWorkbook.ActiveSheet On Error Resume Next Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 91)).ClearContents Path = "d:\data.xlsx" Set WB = Workbooks.Open(Path) '===================================================================== On Error Resume Next Set Sh = WB.Sheets("Data") With Sh .Activate R = Sh.Cells(Sh.Rows.Count, 1).End(xlUp).Row C = Range(Split(Sh.UsedRange.Address, "$")(3) & 1).Column Set myRng = WB.Sheets("Data").Range(.Cells(2, 1), .Cells(R, C)) myRng.Copy shMain.Cells(2, 1).PasteSpecial xlPasteValues End With WB.Close True '===================================================================== On Error GoTo 0 Application.CutCopyMode = False Application.ScreenUpdating = True Application.EnableEvents = False Application.DisplayAlerts = True MsgBox "Task Completed" Application.Goto Reference:="Macro1" Range("D2").Select End Sub

اي اني لم افهم طلبك نسق تقرير لطالب فقط في ورقة البيانات يوجد لديك 10 اعمد ماهيا الاعمد التي تريدها تظهر في التقرير وهل كل رقم اكاديمي يعتبر تقرير

لااعلم هل المشكله من اتصالي ام ماذا لم استطيع تحميل مرفقك الاخير

لو تحط تقرير في ورقة تقرير كسمبل لما تريد

السلام عليكم شاهد المرفق خلاصه_111.rar

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

السلام عليكم جرب هات الطريقه '******************************** ' رابط الدوماين الذي تريد التحقق منه Private Const Ur As String = "https://www.colomos.com" Sub Check_Url() MsgBox IIf(Check_Domin(Ur), "غير شاغر", "شاغر") End Sub Function Check_Domin(Url As String) As Boolean Dim Win_Htp As Object Dim R_a As Variant On Error GoTo Nex Set Win_Htp = CreateObject("WinHttp.WinHttpRequest.5.1") With Win_Htp DoEvents .Open "GET", Url, False .Send R_a = .StatusText End With Set Win_Htp = Nothing If R_a = "OK" Then Check_Domin = True Exit Function Nex: End Function

السلام عليكم اولاً اهلا بك في صرح اوفسينا اخي hhowaydi حبذا تغير اسمك بالعربي ملف الاكسل اضغطه بأحد برامج الضغط Winrar او Winzip ثم ارفقه وان شاء الله لن يقصر معك الجميع تحياتي

بسبب الخلايا المدمجه استخدم هذا الكود او انسخ على خليه خليه Sub Ali_Tr() Set S = Sheets("sheet1"): Set SS = Sheets("sheet2") With S For r = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row SS.Cells(SS.Cells(Rows.Count, 2).End(xlUp).Row + IIf(r = 1, 2, 5), 2) = .Cells(r, 1) Next End With End Sub

السلام عليكم بعد اذن الاستاذ الحبيب عادل حنفي مجرد اثراء للموضوع حل بطريقة اخرى جرب الكود التالي Sub Ali_Trq() Dim Lr As Long, Rw As Long, Rww As Long Dim Rng_Dp As Range, Rng_D As Range, Rng_Empty As Range Dim Sh As Worksheet, Sht As Worksheet '************************************************ ' اسم الورقة التي بها الجدول Set Sh = Sheets("Sheet1") '************************************************ ' اسم الورقة التي تريد بها الجدول بعد الترتيب Set Sht = Sheets("Sheet2") ' Application.ScreenUpdating = False Lr = Split(Sh.UsedRange.Address, "$")(4) Sh.Range("A1:J" & Lr).Copy '=========================================== With Sht .Range("A1").PasteSpecial xlPasteAll .Range("A1").PasteSpecial xlPasteColumnWidths .Activate Set Rng_Dp = .Range("D" & Lr + 1) Set Rng_Empty = .Range("A" & Lr + 1) Set Rng_D = .Range("A" & Lr + 1) For Rw = 2 To Lr If Application.CountIf(.Range("D1:D" & Rw), .Range("D" & Rw)) > 1 Then Set Rng_Dp = Union(Rng_Dp, .Range("D" & Rw)) End If '=========================================== If IsNumeric(.Cells(Rw, 1)) Then If Application.CountIf(.Range("A1:A" & Rw), .Range("A" & Rw)) > 1 Then Set Rng_D = Union(Rng_D, .Range("A" & Rw)) End If End If '=========================================== Next Rw Rng_Dp.Value = "": Rng_D.Value = "" Lr = Split(.UsedRange.Address, "$")(4) For Rww = 2 To Lr If .Cells(Rww, 1) = "" Then Set Rng_Empty = Union(Rng_Empty, .Range("A" & Rww)) End If Next '=========================================== Rng_Empty.EntireRow.Delete xlShiftUp .Range("A1:J" & Lr).Borders.Color = 1 Set Rng_Dp = Nothing Set Rng_Empty = Nothing Set Rng_D = Nothing End With Application.ScreenUpdating = True End Sub

اكتب اي شيء في العمود A ولاحظ النتيجه متى تريد ان يتفعل الكود عند عمل ماذا هل عند الكتابه في عمود معين او عند الضغط على زر محدد ؟

جرب هكذا انت تريد ان يشعرك على الكل Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("A2:A100")) Is Nothing Then On Error Resume Next Dim S$, Nm$, SS$, Msg$, Rw For Rw = 2 To Cells(Rows.Count, 7).End(xlUp).Row If Cells(Rw, 7) <> "" Then S = Cells(Rw, 19) SS = Cells(Rw, 17) Nm = Cells(Rw, 7) If S = "لم يباشر" Then Msg = " يجب على الموظف :" & Nm & " الإتصال على شئون الموظفين " MsgBox Msg End If If SS <= 3 Then Msg = " يجب إدراج الموظف :" & Nm & " في الورديات " MsgBox Msg End If End If Next End If End Sub

السلام عليكم بالامكان بهات الطريقة جرب الكود التالي واذا اردت بفورم لامانع Sub Fd_Ali() Dim Inx As String Dim Trg As Range xn: With ActiveSheet.UsedRange Inx = Application.InputBox("إدخل كلمة البحث", "بحث", "ادخل الكلمه المراد البحث عنها هنا") Set Trg = .Cells.Find(What:=Inx) If Not Trg Is Nothing Then Inx = Application.InputBox(" وجدت في الخليه " & Trg.Address & " ادخل الكلمه البديله ", Trg.Address, " ادخل الكلمه البديله هنا") Trg = Inx msg = MsgBox("هل تريد البحث مجدداً عن كلمه اخرى؟", vbYesNo, "بحث جديد") If msg = vbYes Then GoTo xn Else Exit Sub End If End If End With Set Trg = Nothing End Sub

السلام عليكم يتفعل الكود عند الكتابه في العمود A Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("A2:A100")) Is Nothing Then Dim S$, Nm$, SS$, Msg$, Rw Rw = Target.Row S = Cells(Rw, 19) Nm = Cells(Rw, 7) SS = Cells(Rw, 17) If S = "لم يباشر" Then Msg = " يجب على الموظف :" & Nm & " الإتصال على شئون الموظفين " MsgBox Msg End If If SS <= 3 Then Msg = " يجب إدراج الموظف :" & Nm & " في الورديات " MsgBox Msg End If End If End Sub

السلام عليكم وهذا كود اخر اضافة الى حل الاستاذ الفاضل بن عليه يقوم بأخذ تنسيقات الورقة الرئيسيه من عرض للاعمد والصفوف والخط والبوردر Sub Formt_Ali() Dim Sht As Worksheet Dim Sh As Worksheet Dim Rw&, Col$ Set Sht = Sheets("الرئيسية") With Application .ScreenUpdating = False .EnableEvents = True With Sht Rw = Split(.UsedRange.Address, "$")(4): Col = Split(.UsedRange.Address, "$")(3) .Range("A1:" & Col & Rw).Copy For Each Sh In Sheets Ali_Wdth Sht, Sh, True, True If Not Sh.Name = .Name Then With Sh With .Range("A1:" & Col & Rw) .PasteSpecial xlPasteFormats End With End With End If Next Sh End With .CutCopyMode = False .ScreenUpdating = True .EnableEvents = False End With End Sub Private Sub Ali_Wdth(ByVal Smp_Sht As Variant, ByVal Al_Sht As Variant, Optional Heights As Boolean = False, Optional Widths As Boolean = False) Dim Sc_Rn As Range, D_Rn As Range Dim R As Long, C As Long On Error GoTo Eri With Smp_Sht Set Sc_Rn = Range(.Cells(1, 1), .UsedRange.Cells(.UsedRange.Cells.Count)) End With With Al_Sht Set D_Rn = Range(.Cells(1, 1), .UsedRange.Cells(.UsedRange.Cells.Count)) End With R = WorksheetFunction.Max(Sc_Rn.Rows.Count, D_Rn.Rows.Count) C = WorksheetFunction.Max(Sc_Rn.Columns.Count, D_Rn.Columns.Count) Set Sc_Rn = Sc_Rn.Resize(R, C) Set D_Rn = D_Rn.Resize(R, C) If Heights Then For R = 1 To R D_Rn.Rows(R).RowHeight = Sc_Rn.Rows(R).RowHeight Next End If If Widths Then For C = 1 To C D_Rn.Columns(C).ColumnWidth = Sc_Rn.Columns(C).ColumnWidth Next End If Eri: End Sub

السلام عليكم لم نرى لك رد على العموم شاهد المرفق اذا هذا ماتريد ارفق ملفك لنطبق عليه الفكره لاتنسى اولاً تضغط ملف الاكسل ومن ثم ترفعه في ردك تحياتي Ali_On.rar

اخي الكريم اضغط ملف الاكسل بأحد برامج الضغط Winrar ثم ارفقه سيقبل معك

هذا السطر في الكود On_R = 7 غير 7 حط الرقم 6 ليبداء من اول سطر ضمن ورقة رصيد العملاء On_R = 6

تأكد انا جربت حالياً ويرحل عملت اكثر من فاتورة لاكثر من عميل

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

جرب المرفق اذا ظهرت رسالة خطاء التقطها عبر Prt Scren وطلعنا عليها الكود يقوم بترحيل اجمالي الفاتور الى مدين العميل والى المبيعات alex star_222.rar

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

السلام عليكم كما اشار اخي ياسر خليل كي نثبت قواعد يعمل عليها الكود وهذه محاوله حسب معطيات ملفك الحالي لاحظ ان اسم جميلة غير موجود في صفحة اسماء العملاء تحياتي فصل المتن والاسم والرقم وشيت باسماء العملاء_111.rar