عبدالله بشير عبدالله

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

السلام عليكم حل استاذنا محمد هشام وافى وكافى جزاه الله كل خير وطلبك كان معادلة ان اردتها بالكود غير الصف والمادة فى الخليتن فقط تم عمل قائمة للصفوف A (1).xlsb

الملف المعدل سبق معالجة الامر حيث يتم مسح البيانات قبل استدعاء التواريخ ws.Range(ws.Cells(7, 49), ws.Cells(8, Columns.Count)).ClearContents تم التعدبل حبث يتعامل مع اخر صف به اسم موظف زاد العدد او نقص واذا اردت الغاء موظف احذف الصف بالكامل لو امسحه بالكامل ws.Range("AU9:CM" & lastRow).ClearContents تم التعديل الصف الذى به بيانات يتم مسح التنسيقات ws.Range("AU" & lastRow + 1 & ":CM" & ws.Rows.Count).ClearFormats انمتى ان تجد طلباتك فى هذا الملف وان هناك اي شئ غير مكتمل فابلغنى فان لم اكن انا فالكثير من اعضاء المنتدى يقدمون المساعدة المهم الحصول على طلبك وليس المهم من قام به برعاية الله وحفظه استدعاء التاريخ أفقيا +11111.xlsm

الملف فى المشاركة السابقة جربه

باذن الله جرب الملف استدعاء التاريخ افقيا.xlsm الكود بتعامل مع اخر اسم للموظفين بتم عنده اللصق

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

رابط البرنامج https://www.raed.net/file?id=1067611

التحويل بواسطة برنامج VB6 نسخة خفيفة حوالي 30 ميقا وتعلمتها من المنتدي ويوجد شرح مفصل للطريقة بالمنتدى للاستاذ ياسر العربي حيث قام بشرح تفصيلي لربط الاكسل بالفيجوال بيسك والتحكم بملف الاكسل عن طريقه واما التحويل الى EXEفهي ميزة موجودة بالفيجول بيسك. https://www.officena.net/ib/topic/65629-سلسلة-دروس-الفيجوال-بيسك-6-والاكسيل-من-علي-مصطبة-ياسر-العربي هذا ملف تم تحوبله الى EXE بالبرنامج المذكور المصنف1.rar

تم التعديل فى المشاركة السابفة حمل الملف من جديد

وعليكم السلام ورحمة الله وبركاته تم معالجة النقطة الثاتبة وهو مسح النطاق اولا Range(Cells(7, 49), Cells(8, Columns.Count)).ClearContents التنسبق لدى فى جهازى من البمبن الى البسار واذ كان يظهر لك غير ذلك بمكنك تظليل نطاق التواربخ وبالزر الابمن اختر تنسبق خلابا ثم التاريخ واختر التنسبق المطلوب من القائمة او تعديلها من اعدادات اللغة والتاريخ لك وافر التقدبر والاحترام تعدبل الكود Sub FillDatesAndNames() Dim startDate As Date Dim endDate As Date Dim currentDate As Date Dim colIndex As Integer Range(Cells(7, 49), Cells(8, Columns.Count)).ClearContents startDate = Range("AU8").Value endDate = Range("AV8").Value colIndex = 49 For currentDate = startDate To endDate If Weekday(currentDate, vbSunday) <> 6 And Weekday(currentDate, vbSunday) <> 7 Then Cells(8, colIndex).Value = currentDate Cells(7, colIndex).Value = Format(currentDate, "dddd") colIndex = colIndex + 1 End If Next currentDate End Sub الملف استدعاء التاريخ افقيا.xlsm

السلام عليكم حسب طلبك اكتب فى A1 الصف الذى تربد البحث فيه واكتب فى A2 رقم عمود البيانات الذى تربد البحث فيه نتيجة البحثت جدها فى A3 يمكنك البحث فى نفس العمود او غيره تحياتى =INDIRECT(ADDRESS(A1; A2)) بحث في اي صف او عمود.xlsb

وعليكم السلام ورحمة الله وبركاته تم عمل كود بزر 1-1.xlsb ملفك وبه المغادلة 1-1.xlsx

وعليكم السلام ورحمة الله وبركاته في صفحة مبيعات اكتب عدد صتف قمت ببيعة بتم انقاصه من المخزن وان كررت الصنف يتم انقاصه كذلك في حالة كتابة اسم الصنف خطأ تاتى رسالة بذلك في حالة عدد المبيع اكبر ما هو موجود بالمخزن تاتى رسالة بذلك الكود Private Sub Worksheet_Change(ByVal Target As Range) Dim wsMokhzan As Worksheet Dim wsMabieat As Worksheet Dim productName As String Dim soldQuantity As Long Dim foundCell As Range Set wsMokhzan = ThisWorkbook.Sheets("مخزن") Set wsMabieat = ThisWorkbook.Sheets("مبيعات") If Not Intersect(Target, wsMabieat.Range("E5:E" & wsMabieat.Cells(wsMabieat.Rows.Count, "E").End(xlUp).Row)) Is Nothing Then Application.EnableEvents = False For Each cell In Intersect(Target, wsMabieat.Range("E5:E" & wsMabieat.Cells(wsMabieat.Rows.Count, "E").End(xlUp).Row)) If IsNumeric(cell.Value) And cell.Value > 0 Then productName = cell.Offset(0, -1).Value soldQuantity = cell.Value Set foundCell = wsMokhzan.Range("B4:B" & wsMokhzan.Cells(wsMokhzan.Rows.Count, "B").End(xlUp).Row).Find(What:=productName, LookIn:=xlValues, LookAt:=xlWhole) If Not foundCell Is Nothing Then If wsMokhzan.Cells(foundCell.Row, "C").Value >= soldQuantity Then wsMokhzan.Cells(foundCell.Row, "C").Value = wsMokhzan.Cells(foundCell.Row, "C").Value - soldQuantity Else cell.Value = "" cell.Value = "" End If Else MsgBox "المنتج " & productName & " غير موجود في المخزن", vbExclamation cell.Value = "" End If End If Next cell Application.EnableEvents = True End If End Sub الملف طرح المباع من المخزن.xlsb

الكود بضاف في حدث الورقة بدون زر وبوجد ملفك وبه الكود فى المشاركة السابقة حمل الملف واذا كان الماكرو غير مفعل فقم بتفعيله تمكبن المحتوى بعد فتح الملف اكتب فى العمو دC كلمة البحث فقط تاتى لك بالنسبة% الملف مرة اخرى وشغال 100% بحث بجزء من الجمله1.xls

وعليكم السلام ورحمة الله وبركاته ما قمت به انا حسب ملفك المرفق اكتب فى العمود C كلمة البحث بكلمة كاملة او بحرف منها تجد النسبة مكتوبة فى العمود E الكود Private Sub Worksheet_Change(ByVal Target As Range) Dim cell As Range Dim searchRange As Range Dim foundCell As Range If Not Intersect(Target, Me.Range("C4:C" & Me.Rows.Count)) Is Nothing Then Set searchRange = Me.Range("A1:A" & Me.Cells(Me.Rows.Count, "A").End(xlUp).Row) For Each cell In Intersect(Target, Me.Range("C4:C" & Me.Rows.Count)) If cell.Value <> "" Then Set foundCell = searchRange.Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False) If Not foundCell Is Nothing Then cell.Offset(0, 2).Value = foundCell.Offset(0, 1).Value Else cell.Offset(0, 2).Value = "لا يوجد" End If Else cell.Offset(0, 2).ClearContents End If Next cell End If End Sub الملف بحث بجزء من الجمله1.xls

السلام عليكم من المفترض وجود ملف للعمل عليه تم عمل كود مرن يقوم بالبحث في اي صف او اي عمود بالصفحة الكود Sub GetCellValueByRowAndCol() Dim inputValue As String Dim rowNum As Long Dim colNum As Long Dim cellValue As Variant On Error Resume Next inputValue = InputBox("أدخل رقم الصف ورقم العمود مفصولين بشرطة، مثال: 5-4") rowNum = Split(inputValue, "-")(0) colNum = Split(inputValue, "-")(1) cellValue = ThisWorkbook.Sheets("Sheet1").Cells(rowNum, colNum).Value If IsEmpty(cellValue) Then MsgBox "قيمة الخلية " & Cells(rowNum, colNum).Address & " هي: لا توجد قبمة" Else MsgBox "قيمة الخلية " & Cells(rowNum, colNum).Address & " هي: " & cellValue End If End Sub الملف بحث في اي صف او عمود.xlsb

وعليكم السلام ورحمة الله وبركاته هناك بعض الغموض في الطلب ع ما تم تنفبذه حسب الملف البحث فى العمود A باي حرف او كلمة عند العثور عليها يضعها فى C4 ونسبتها في E4 اذا تكرر البحث يدرج ما تم البحث عنه في صف جديد مع نسبته وهكذا اذا لم يجد الكلمة تانى رسالة بعدم وجودها اذا لم يكن هذا طلبك ارجو التوضيح اكثر الكود Sub SearchAndCopy() Dim ws As Worksheet Dim searchWord As String Dim cell As Range Dim outputRow As Long Dim found As Boolean Set ws = ThisWorkbook.Sheets("SHEET1") searchWord = InputBox("أدخل الكلمة التي تريد البحث عنها:") If searchWord = "" Then Exit Sub outputRow = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row + 1 If outputRow < 4 Then outputRow = 4 found = False For Each cell In ws.Range("A1:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row) If InStr(1, cell.Value, searchWord, vbTextCompare) > 0 Then ws.Cells(outputRow, 3).Value = searchWord ws.Cells(outputRow, 5).Value = cell.Offset(0, 1).Value outputRow = outputRow + 1 found = True End If Next cell If Not found Then MsgBox "لم يتم العثور على الكلمة المطلوبة.", vbExclamation Else MsgBox "تم البحث والنقل بنجاح.", vbInformation End If End Sub الملف بحث بجزء من الجمله.xls

قمت بعمل مثال لك بفصل الحالات الثلاتة كما طلبت الكود Sub FilterValues() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("Sheet1") Dim lastRow As Long lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row ws.Range("G2:H" & ws.Cells(ws.Rows.Count, "G").End(xlUp).Row).ClearContents ws.Range("I2:J" & ws.Cells(ws.Rows.Count, "I").End(xlUp).Row).ClearContents ws.Range("K2:L" & ws.Cells(ws.Rows.Count, "K").End(xlUp).Row).ClearContents Dim negArr() As Variant Dim posArr() As Variant Dim zeroArr() As Variant Dim i As Long, negCount As Long, posCount As Long, zeroCount As Long Dim dataRange As Range Set dataRange = ws.Range("B2:C" & lastRow) Dim dataArr As Variant dataArr = dataRange.Value ReDim negArr(1 To UBound(dataArr, 1), 1 To 2) ReDim posArr(1 To UBound(dataArr, 1), 1 To 2) ReDim zeroArr(1 To UBound(dataArr, 1), 1 To 2) negCount = 0 posCount = 0 zeroCount = 0 For i = 1 To UBound(dataArr, 1) Select Case dataArr(i, 2) Case Is < 0 negCount = negCount + 1 negArr(negCount, 1) = dataArr(i, 1) negArr(negCount, 2) = dataArr(i, 2) Case Is > 0 posCount = posCount + 1 posArr(posCount, 1) = dataArr(i, 1) posArr(posCount, 2) = dataArr(i, 2) Case Else zeroCount = zeroCount + 1 zeroArr(zeroCount, 1) = dataArr(i, 1) zeroArr(zeroCount, 2) = dataArr(i, 2) End Select Next i ws.Range("G2").Resize(negCount, 2).Value = Application.Index(negArr, Evaluate("ROW(1:" & negCount & ")"), Array(1, 2)) ws.Range("I2").Resize(posCount, 2).Value = Application.Index(posArr, Evaluate("ROW(1:" & posCount & ")"), Array(1, 2)) ws.Range("K2").Resize(zeroCount, 2).Value = Application.Index(zeroArr, Evaluate("ROW(1:" & zeroCount & ")"), Array(1, 2)) End Sub الملف فصل الدائن والمدين والصفرية الى اعمدة جديدة.xlsb

السلام عليكم ورحمة الله وبركاته صباح الخير الاستاذ سعيد بما اننا في نفس العمر تقريبا 61 سنة واشتراكنا بالمنتدى تقريبا فى نفس السنة بفارق عام اهديك هذا الملف مع تحياتنا الخالصة لاخينا الاستاذ محمد هشام وادعو الله ان يمدكما بطول العمر ويمتعكما بالصحة وراحة البال والرزق الوفير بمكن كتابة تاريخ البدابة والتهاية يدوبا في L2 -N2 فتتم العملية الزر في الصفحة اخنياري ولبس اساسى مهمته انك تكتب تاربخ البداية بدويا ثم تكتب عدد الايام المراد اظافتها الى التاريخ في N3 ثم اضغط على الزر فبظفها الى تاريخ النهاية تحياتى لكما ولكل اخوتنا في هذا المنتدى انقسام الشهور على قائمتبن.xlsm

السلام عليكم اثراء للموضوع وتنوع الحلول وبعد اذن استاذنا الفاضل محمد هشام الكود Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("L2:M2")) Is Nothing Then Dim startDate As Date Dim endDate As Date Dim currentDate As Date Dim outputRow As Long startDate = Me.Range("L2").Value endDate = Me.Range("M2").Value outputRow = 6 Me.Range("K6:L" & Me.Rows.Count).ClearContents For currentDate = startDate To endDate If Weekday(currentDate, vbSunday) <> 6 And Weekday(currentDate, vbSunday) <> 7 Then Me.Cells(outputRow, 11).Value = Format(currentDate, "dddd") Me.Cells(outputRow, 12).Value = currentDate outputRow = outputRow + 1 End If Next currentDate End If End Sub الملف تسلسل الأيام بدون أيام 2الجمعة والسبت.xlsm

السلام عليكم حقيقة كود الفاضل محمد هشام حاولت فهمه لم اتمكن من استيعابه بالكامل لانى حاولت التعدبل فيه بسبب الصورة المتحركة عند اختياره شهر 12 ظهر بالصورة بداية الشهر الاحد يوافق يوم 8 وحسب التقوبم الشهر يبدأ يوم 1 طبعا لم اجرب الملف كما قلت حسب الصورة المتحركة تأمل من استاذنا الفاضل تعدبل الكود للاستفاذة ربما التعديل التالى لاختيار التاريخ يناسبك بمكن تعديل السنوات من الكود أيام الشهر من يوم محدد - vba (1).xlsm

وعليكم السلام ورحمة الله وبركاته الاستاذ محمد هشام في المشاركة السابقة اخبرك (في حالة كنت تستخدم إصدار قديم لن تشتغل معك الصيغ. أخبرني بذالك لمحاولة إنشاء دالة أو كود vba ينفذ نفس المهمة) حسب ملفك الحالى كود في حدث الورقة كلما تم التغيير في M2 يتم التغيير في الاعمدة الملف أيام الشهر من يوم محدد - vba (1).xlsm

السلام عليكم بعد اذنكما محاولة حسب فهمى لطلبك فى الملف المرفق باول مشاركة عن طربق الكود في حدث الورقة الكود Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("C2")) Is Nothing Then Me.Range("A5:B" & Me.Rows.Count).ClearContents Dim monthYear As Date Dim firstDay As Date Dim lastDay As Date Dim currentDay As Date Dim outputRow As Long monthYear = Me.Range("C2").Value firstDay = DateSerial(Year(monthYear), Month(monthYear), 1) lastDay = DateSerial(Year(monthYear), Month(monthYear) + 1, 0) Dim startDay As Date startDay = firstDay Do While Weekday(startDay, vbSunday) <> vbSunday startDay = startDay + 1 Loop outputRow = 5 For currentDay = startDay To lastDay If Weekday(currentDay, vbSunday) <= 5 Then Me.Cells(outputRow, 2).Value = currentDay Select Case Weekday(currentDay, vbSunday) Case 1 Me.Cells(outputRow, 1).Value = "الأحد" Case 2 Me.Cells(outputRow, 1).Value = "الإثنين" Case 3 Me.Cells(outputRow, 1).Value = "الثلاثاء" Case 4 Me.Cells(outputRow, 1).Value = "الأربعاء" Case 5 Me.Cells(outputRow, 1).Value = "الخميس" End Select outputRow = outputRow + 1 End If Next currentDay End If End Sub الملف أيام الشهر من يوم محدد.xlsb

وعليكم السلام ورحمة الله وبركاته الكود Sub ExtractAbsentees() Dim ws As Worksheet Dim lastRow As Long, lastCol As Long Dim i As Long, j As Long Dim outputRow As Long Set ws = ThisWorkbook.Sheets("SHEET1") lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row lastCol = ws.Cells(4, ws.Columns.Count).End(xlToLeft).Column outputRow = 5 For i = 5 To lastRow For j = 4 To lastCol If ws.Cells(i, j).Value = "A" Then ws.Cells(outputRow, 15).Value = ws.Cells(i, 2).Value ws.Cells(outputRow, 16).Value = ws.Cells(4, j).Value outputRow = outputRow + 1 End If Next j Next i End Sub الملف الغياب.xlsb

ما شاء الله استاذ محمد معادلة وكود . اثراء للموضوع المعادلة التالية تؤدى الى نفس النتيجة وهى تستخدم دالة AGGREGATE لتحديد آخر عمود يحتوي على قيمة غير فارغة، ومن ثم دالة INDEX لاسترجاع القيمة المطابقة. المعاداة =IFERROR( IF(A14=""; ""; INDEX($B$2:$E$9; MATCH(A14; $A$2:$A$9; 0); AGGREGATE(14; 6; COLUMN($B$2:$E$2) / (INDEX($B$2:$E$9; MATCH(A14; $A$2:$A$9; 0); 0)<>""); 1) - COLUMN($B$2) + 1) ); "بدون نتيجة") الملف اخر ادخال بالصف.xlsx