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

كود ربما اسرع جربه نقل أعمدة محددة من ورقة الى أكثر من ورقة.xlsm

اللهم صَلِّ وسلم على نبينا محمد وعلى آله وصحبه أجمعين السلام عليكم ابو سجدة جرب الكود التالى ومعك ان شاء الله حتى تحقق طلبك الكود Sub نقل_الأعمدة() Dim wsMain As Worksheet Dim wsFirst As Worksheet Dim wsSecond As Worksheet Dim wsThird As Worksheet Dim lastRow As Long Dim colArr As Variant Set wsMain = Sheets("الرئيسية") Set wsFirst = Sheets("الورقة الأولى") Set wsSecond = Sheets("الورقة الثانية") Set wsThird = Sheets("الورقة الثالثة") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual colArr = Array(1, 4, 6, 28, 29) نقل_عمود_مع_التنسيقات wsMain, wsFirst, colArr colArr = Array(1, 2, 3, 4, 5, 6, 46) نقل_عمود_مع_التنسيقات wsMain, wsSecond, colArr colArr = Array(1, 4, 6, 17, 18, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45) نقل_عمود_مع_التنسيقات wsMain, wsThird, colArr Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub Sub نقل_عمود_مع_التنسيقات(wsSource As Worksheet, wsTarget As Worksheet, cols As Variant) Dim lastRow As Long Dim i As Long Dim colNum As Integer lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row For i = LBound(cols) To UBound(cols) colNum = cols(i) wsTarget.Columns(colNum).ClearContents Next i For i = LBound(cols) To UBound(cols) colNum = cols(i) wsSource.Range(wsSource.Cells(1, colNum), wsSource.Cells(lastRow, colNum)).Copy wsTarget.Cells(1, colNum).PasteSpecial Paste:=xlPasteValuesAndNumberFormats wsTarget.Cells(1, colNum).PasteSpecial Paste:=xlPasteFormats Next i Application.CutCopyMode = False End Sub نقل أعمدة محددة من ورقة الى أكثر من ورقة.xlsm

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

اذا تغير اسم الملف فلن تكون هناك نتائج الملف يعمل بامتياز تم تعديل ملف ايلول ياسم A وتشرين B حمل الملفات الثلاتة التالية وضعها على سطح المكتب وافتح ملف نتائج المقارنة واضغط على الزر A.xlsx B.xlsx نتائج المقارنة.xlsb

جرب الكود التالى النتيجة فى G2 بمكن تعديلها فى الكود Sub CalculateResult() Dim cellCount As Long Dim result As Variant Dim dataRange As Range Dim cell As Range Set dataRange = Sheets("طباعة").Range("B7:I11") cellCount = 0 For Each cell In dataRange If cell.Value <> 0 And cell.Value <> "" Then cellCount = cellCount + 1 End If Next cell Select Case Sheets("طباعة").Range("F2").Value Case "الأول", "الثانى" If cellCount >= 25 Then result = 25 Else result = cellCount End If Case "الثالث" result = cellCount Case Else result = "" End Select Sheets("طباعة").Range("G2").Value = result MsgBox "تم حساب النتيجة: " & result الملف عدد الخلايا بشروط.xlsx

كذاك جرب المعادلة التالية فهل تتجاهل الفراغات والخلايا الصفرية =IF(OR(F23="الأول";F23="الثانى");IF(SUMPRODUCT(--(B11:I15<>0);--(B11:I15<>""))>=25;25;SUMPRODUCT(--(B11:I15<>0);--(B11:I15<>"")));IF(F23="الثالث";SUMPRODUCT(--(B11:I15<>0);--(B11:I15<>""));""))

نعم يمكن ذلك الملف به 3 اكواد عمل المعادلات بكود1.xlsb

السلام عليكم بعد اذن استاذنا الفاضل محمد هشام محاولة منى للمساهمة فى ملف اخينا ناصر المصرى اذا لم تحقق المطلوب ارفق الملف بالمعادلات =IF(OR(F23="الأول"; F23="الثانى"); IF(COUNTA(B11:I15) >= 25; 25; COUNTA(B11:I15)); IF(F23="الثالث"; COUNTA(B11:I15); "")) الملف عدد الخلايا بشروط.xlsx

السلام عليكم تم انشاء ملف جديد باسم نتائج المقارنة تم وضع كود به اضغط على الزر فقط بشرط الملفين تشرين وايلول يكونان مقفلين وان بكونا على سطح المكتب بمعنى الملفات الثلاتة على سطح المكتب وبنفس الاسماء الحالية يمكنك تعديل الاسماء من الكود ان اردت Sub CompareSalaries() Dim desktopPath As String Dim wb1 As Workbook, wb2 As Workbook, ws1 As Worksheet, ws2 As Worksheet Dim resultWb As Workbook, resultWs As Worksheet Dim lastRow1 As Long, lastRow2 As Long, i As Long, j As Long Dim empName As Variant Dim salary1 As Double, salary2 As Double Dim dictSalaries1 As Object, dictSalaries2 As Object desktopPath = Environ("UserProfile") & "\Desktop\" Application.ScreenUpdating = False Application.Calculation = xlCalculationManual On Error GoTo ErrorHandler Set wb1 = Workbooks.Open(desktopPath & "__ايلول_.xlsx") Set wb2 = Workbooks.Open(desktopPath & "__تشرين الاول_.xlsx") Set resultWb = Workbooks("نتائج المقارنة.xlsB") Set ws1 = wb1.Sheets("ورقة1") Set ws2 = wb2.Sheets("ورقة1") Set resultWs = resultWb.Sheets("ورقة1") resultWs.Range("A2:D" & resultWs.Rows.Count).ClearContents resultWs.Range("A1:D1").Value = Array("الاسم", "الحالة", "راتب أيلول", "راتب تشرين الأول") Set dictSalaries1 = CreateObject("Scripting.Dictionary") Set dictSalaries2 = CreateObject("Scripting.Dictionary") lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRow1 empName = ws1.Cells(i, 1).Value salary1 = ws1.Cells(i, 2).Value dictSalaries1(empName) = salary1 Next i lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRow2 empName = ws2.Cells(i, 1).Value salary2 = ws2.Cells(i, 2).Value dictSalaries2(empName) = salary2 Next i j = 2 For Each empName In dictSalaries1.Keys If dictSalaries2.exists(empName) Then salary1 = dictSalaries1(empName) salary2 = dictSalaries2(empName) If salary1 <> salary2 Then resultWs.Cells(j, 1).Value = empName resultWs.Cells(j, 2).Value = "تغير في الراتب" resultWs.Cells(j, 3).Value = salary1 resultWs.Cells(j, 4).Value = salary2 j = j + 1 End If Else resultWs.Cells(j, 1).Value = empName resultWs.Cells(j, 2).Value = "محذوف" resultWs.Cells(j, 3).Value = dictSalaries1(empName) resultWs.Cells(j, 4).Value = "" j = j + 1 End If Next empName For Each empName In dictSalaries2.Keys If Not dictSalaries1.exists(empName) Then resultWs.Cells(j, 1).Value = empName resultWs.Cells(j, 2).Value = "جديد" resultWs.Cells(j, 3).Value = "" resultWs.Cells(j, 4).Value = dictSalaries2(empName) j = j + 1 End If Next empName wb1.Close False wb2.Close False resultWs.Columns("A:D").AutoFit With resultWs.Range("A1:D" & j - 1).Borders .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With MsgBox "تمت المقارنة وتم عرض النتائج في ورقة 'ورقة1' في مصنف 'نتائج المقارنة.xlsx'.", vbInformation Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical If Not wb1 Is Nothing Then wb1.Close False If Not wb2 Is Nothing Then wb2.Close False Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub الملف نتائج المقارنة.xlsb

السلام عليكم الكود Sub ترحيل_الناجحين_والراسبين() Dim wsSource As Worksheet Dim wsPass As Worksheet Dim wsFail As Worksheet Dim lastRow As Long Dim i As Long Dim passRow As Long Dim failRow As Long Dim passCount As Long Dim failCount As Long Set wsSource = ThisWorkbook.Sheets("اجمالي4") Set wsPass = ThisWorkbook.Sheets("ناجح4") Set wsFail = ThisWorkbook.Sheets("دور ثاني") lastRow = wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).Row passRow = 7 failRow = 7 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual wsPass.Rows("7:" & wsPass.Rows.Count).ClearContents wsFail.Rows("7:" & wsFail.Rows.Count).ClearContents For i = 5 To lastRow If InStr(1, LCase(wsSource.Cells(i, "BC").Value), "ناجح") > 0 Then wsPass.Cells(passRow, 2).Resize(1, 56).Value = wsSource.Cells(i, 2).Resize(1, 56).Value wsPass.Cells(passRow, 1).Value = passRow - 6 wsPass.Cells(passRow, 1).NumberFormat = wsSource.Cells(i, 1).NumberFormat ' نسخ التنسيق passRow = passRow + 1 passCount = passCount + 1 ElseIf InStr(1, LCase(wsSource.Cells(i, "BC").Value), "راسب") > 0 Then wsFail.Cells(failRow, 2).Resize(1, 56).Value = wsSource.Cells(i, 2).Resize(1, 56).Value wsFail.Cells(failRow, 1).Value = failRow - 6 wsFail.Cells(failRow, 1).NumberFormat = wsSource.Cells(i, 1).NumberFormat ' نسخ التنسيق failRow = failRow + 1 failCount = failCount + 1 End If Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic If passCount = 0 Then MsgBox "لا توجد سجلات ناجحة للترحيل." ElseIf failCount = 0 Then MsgBox "لا توجد سجلات راسبة للترحيل." Else MsgBox "تم ترحيل " & passCount & " ناجح(ة) و " & failCount & " راسب(ة) بنجاح." End If End Sub الملف عمل المعادلات بكود1.xlsb

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

السلام عليكم حل استاذنا محمد هشام وافى وكافى جزاه الله كل خير وطلبك كان معادلة ان اردتها بالكود غير الصف والمادة فى الخليتن فقط تم عمل قائمة للصفوف 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