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

رابط البرنامج 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

السلام عليكم اذاكانت الملفات المرتبطة عددها بسيط استخدم الطريقة اليدوية التالية فتح الملف الرئيسي: افتح ملف Excel الرئيسي الذي يحتوي على الروابط إلى الملفات الأخرى. تحرير الروابط: اذهب إلى علامة التبويب "البيانات" (Data) في الشريط. اضغط على "تحرير الروابط" (Edit Links) التي توجد عادة في مجموعة "الاتصالات" (Connections). تغيير مصدر الروابط: ستظهر لك نافذة تحتوي على جميع الروابط الموجودة في الملف. حدد الروابط التي تحتاج إلى تحديث، ثم اضغط على "تغيير المصدر" (Change Source). اختيار الموقع الجديد: اختر الملفات من الموقع الجديد الذي تم نقلها إليه. تحديث الروابط: بعد اختيار الملفات، اضغط على "موافق" لتحديث الروابط إلى الموقع الجديد. اذ كانت الروابط كثيرة فاستخدم الكود التالى Sub UpdateLinks() Dim OldLink As String Dim NewLink As String Dim LinkArray As Variant Dim i As Integer ' الرابط القديم OldLink = "C:\المسار_القديم\" ' الرابط الجديد NewLink = "C:\المسار_الجديد\" LinkArray = ActiveWorkbook.LinkSources(Type:=xlExcelLinks) If Not IsEmpty(LinkArray) Then For i = LBound(LinkArray) To UBound(LinkArray) If InStr(LinkArray(i), OldLink) > 0 Then ActiveWorkbook.ChangeLink Name:=LinkArray(i), NewName:=Replace(LinkArray(i), OldLink, NewLink), Type:=xlExcelLinks End If Next i End If MsgBox "تم تحديث الروابط بنجاح!", vbInformation End Sub قم بتعديل المسارات (OldLink و NewLink) حسب الموقع القديم والجديد للملفات.

المعادلة =IF(B2="";"";IF(B2<=C2;2%;"1%")) الملف تحقق التارحت.xlsx

الكود يرتب ابجدي ويحذف التكرار Private Sub UserForm_Initialize() Dim ws As Worksheet Dim rng As Range Dim data As Variant Dim sortedData As Variant Dim uniqueData As Collection Dim i As Long, j As Long Dim temp As Variant Set ws = ThisWorkbook.Sheets("Sheet3") Set rng = ws.Range("D2:D" & ws.Cells(ws.Rows.Count, "D").End(xlUp).Row) data = rng.Value ReDim sortedData(1 To UBound(data, 1), 1 To 1) For i = 1 To UBound(data, 1) sortedData(i, 1) = data(i, 1) Next i For i = 1 To UBound(sortedData, 1) - 1 For j = i + 1 To UBound(sortedData, 1) If sortedData(i, 1) > sortedData(j, 1) Then temp = sortedData(i, 1) sortedData(i, 1) = sortedData(j, 1) sortedData(j, 1) = temp End If Next j Next i Set uniqueData = New Collection On Error Resume Next For i = 1 To UBound(sortedData, 1) uniqueData.Add sortedData(i, 1), CStr(sortedData(i, 1)) Next i On Error GoTo 0 With Me.ComboBox1 .Clear For i = 1 To uniqueData.Count .AddItem uniqueData(i) Next i End With With Me.ComboBox2 .Clear For i = 1 To uniqueData.Count .AddItem uniqueData(i) Next i End With End Sub الملف ترتيب البيانات ابجديا.xlsm

وعليكم السلام ورحمة الله وبركاته جرب الملف الكود Sub CalculateNetValues() Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim dict As Object Dim key As Variant Dim totalValue As Double Dim expenseValue As Double Dim netValue As Double Set ws = ThisWorkbook.Sheets("Sheet1") lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row Set dict = CreateObject("Scripting.Dictionary") For i = 4 To lastRow If Not dict.exists(ws.Cells(i, "C").Value) Then dict.Add ws.Cells(i, "C").Value, ws.Cells(i, "D").Value Else dict(ws.Cells(i, "C").Value) = dict(ws.Cells(i, "C").Value) + ws.Cells(i, "D").Value End If Next i For i = 4 To lastRow If dict.exists(ws.Cells(i, "C").Value) Then If IsNumeric(ws.Cells(i, "J").Value) Then dict(ws.Cells(i, "C").Value) = dict(ws.Cells(i, "C").Value) - ws.Cells(i, "J").Value End If End If Next i netValue = 0 For Each key In dict.keys netValue = netValue + dict(key) Next key ws.Range("O5").Value = netValue End Sub الملف تجارب اجمالى العهدة.xlsb

تفضل جرب الملف ذكور ثم انات 1.xlsb

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