-
Posts
673 -
تاريخ الانضمام
-
تاريخ اخر زياره
-
Days Won
31
نوع المحتوي
المنتدى
مكتبة الموقع
معرض الصور
المدونات
الوسائط المتعددة
كل منشورات العضو عبدالله بشير عبدالله
-
تعديل كود فورم استعلام وطباعة
عبدالله بشير عبدالله replied to جلال محمد's topic in منتدى الاكسيل Excel
اخي العزيز Foksh عذرا الملاحظتان كانت لصاحب الموضوع ولبست لكم استاذنا الفاضل فانتم اجبتم حسب طلب صاحب الموضوع وابدعتم والملاحظتان وخصوصا الثانية تبهت اليها صاحب الموضوع ان كان البحث لقصل واحد فملفه لا يحتاج الى شيئ وان كان البحث لاكثر من فصل فملفه يحتاج الى تعديل يمكنه طلب ذلك في موضوع جديد وحفيفة انا لست متخصص بل هاو للاكسل ويتقصنى الكثير لنعلمه وخصوصا ان دراستي بعيدة كل البعد عن البرمجة والحاسوب فتخصصى الفعلي هندسة معادن ومتخرج سنة 1983م وقتها لا يوجد حاسوب في مناهج الدراسة وتعلمت في هذه المدرسة مدرسة اوقيسنا ايام المبدع عبدالله باقشير وغيره من الاسابذة الافاضل اشتركت بالمنتدى 2011 ثم نسيت الايميل المشترك به ثم اشتركت من جديد يالمنتدى 2022 حاليا محال على المعاش لك ولكل اعضاء المنتدى كل التقدير والاخترام -
تعديل كود فورم استعلام وطباعة
عبدالله بشير عبدالله replied to جلال محمد's topic in منتدى الاكسيل Excel
السلام عليكم ورحمة الله بركاته مبدع دائما معلمنا Foksh ملاحظنان للاستاذ جلال محمد الاولى في بداية اكواد الفورم Private Const DATE_COL_START As Long = 7 قم بتعديل 7 الى 5 وهو اول عمود به تاريخ في الشيت الملاحظة الثانية الخيار الاخير في القورم غياب مدة بين تاريخين لعدة فصول وتاتى رسالة MsgBox "اختر فصل واحد على الأقل", فاذا كان الخيار فصل واحد لا مشكلة ولكن اذا اردنا اختيار اكثر من فصل فلا توجد وسيلة لذلك لان الفصول في الكائن cmbClass هو ComboBox، وليس ListBox، ولذلك لا يحتوي على خاصية .Selected(index)، فهي خاصة بالكائنات التي تسمح بتحديد متعدد مثل ListBox من النوع fmMultiSelectMulti فاعتقد استبدال cmbClass ب ListBox افضل للخيار الاخير لكما وافر التقدير والاحترام -
عمل متوسط شهرى لعدد من المنتجات
عبدالله بشير عبدالله replied to q8q8q's topic in منتدى الاكسيل Excel
السلام عليكم ورحمة الله وبركاته يمكن بواسطة معادلة =IFERROR(AVERAGEIFS(table1!$A:$A; table1!$C:$C; $C5; table1!$E:$E; D$4);"") او كود يفوم بجلب الاصناف مع متوسط كل صنف Sub حساب_المتوسط_و_جلب_الاصناف() Dim wsIn As Worksheet, wsOut As Worksheet Dim lastRowIn As Long Dim dataArr As Variant Dim i As Long Dim prod As String, price As Double Dim dt As Variant, mon As Long Dim sums As Object, counts As Object, uniqueProds As Object Dim key As String Dim prodList As Variant Dim r As Long, c As Long Dim lastRowOut As Long Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set wsIn = Sheets("table1") Set wsOut = Sheets("sheet1") Set sums = CreateObject("Scripting.Dictionary") Set counts = CreateObject("Scripting.Dictionary") Set uniqueProds = CreateObject("Scripting.Dictionary") lastRowIn = wsIn.Cells(wsIn.Rows.Count, "A").End(xlUp).Row If lastRowIn < 2 Then Exit Sub dataArr = wsIn.Range("A2:D" & lastRowIn).Value For i = 1 To UBound(dataArr, 1) prod = CStr(dataArr(i, 3)) dt = dataArr(i, 4) If Len(prod) > 0 And IsDate(dt) Then mon = Month(dt) price = dataArr(i, 1) key = prod & "_" & mon If Not sums.Exists(key) Then sums(key) = 0 counts(key) = 0 End If sums(key) = sums(key) + price counts(key) = counts(key) + 1 If Not uniqueProds.Exists(prod) Then uniqueProds(prod) = True End If End If Next i wsOut.Range("C5:C10000").ClearContents prodList = uniqueProds.Keys For i = 0 To UBound(prodList) wsOut.Cells(5 + i, "C").Value = prodList(i) Next i lastRowOut = wsOut.Cells(wsOut.Rows.Count, "C").End(xlUp).Row For r = 5 To lastRowOut prod = wsOut.Cells(r, "C").Value For c = 4 To 15 mon = wsOut.Cells(4, c).Value key = prod & "_" & mon If sums.Exists(key) Then wsOut.Cells(r, c).Value = sums(key) / counts(key) Else wsOut.Cells(r, c).ClearContents End If Next c Next r Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True End Sub تحيانى لك ولمعلمنا الفاضل أ / محمد صالح متوسط الاصناف كود.xlsb متوسط الاصناف معادلة.xlsx -
السلام عليكم ورحمة الله وبركاته الكود المرفق في طلبك الاول لا يتناسب مع وافع الملف وخصوصا النطاقات K13:KJ - H14:H فهي ليس لها اهمية خسب ملفك المرفق اليك التعديل حسب فهمى لفكرة عمل ملفك يتم ما تم ترخيله باللون الاصفر ويمكن الغائها من الكود بحذف السطر w.Sheets("Galal").Cells(cell2.Row, c).Interior.Color = RGB(255, 255, 153) الكود Sub dahmour() Dim w As Workbook Dim L As Variant Dim r1 As Long, r2 As Long, c As Long Dim cell As Range, cell2 As Range Dim colNum As Long Dim matched As Boolean Dim rng As Range, cellDate As Range Set w = ActiveWorkbook L = w.Sheets("Sheet2").Range("D2").Value If L = "" Then MsgBox "يرجى اختيار التاريخ من الخلية D2!", vbExclamation Exit Sub End If r1 = w.Sheets("Sheet2").Cells(w.Sheets("Sheet2").Rows.Count, 1).End(xlUp).Row r2 = w.Sheets("Galal").Cells(w.Sheets("Galal").Rows.Count, 1).End(xlUp).Row Set rng = w.Sheets("Galal").Range("E7:Z7") c = 0 For Each cellDate In rng If IsDate(cellDate.Value) And IsDate(L) Then If CDate(cellDate.Value) = CDate(L) Then c = cellDate.Column Exit For End If End If Next cellDate If c = 0 Then MsgBox "لم يتم العثور على التاريخ '" & L & "' في الصف 7 من ورقة Galal", vbCritical Exit Sub End If If IsNumeric(w.Sheets("Sheet2").Range("K4").Value) Then colNum = w.Sheets("Sheet2").Range("K4").Value Else MsgBox "الخانة K4 يجب أن تحتوي على رقم العمود المراد ترحيله!", vbExclamation Exit Sub End If matched = False For Each cell In w.Sheets("Sheet2").Range("A11:A" & r1) If Trim(cell.Value) <> "" Then For Each cell2 In w.Sheets("Galal").Range("A8:A" & r2) If Trim(cell.Value) = Trim(cell2.Value) Then w.Sheets("Galal").Cells(cell2.Row, c).Value = w.Sheets("Sheet2").Cells(cell.Row, colNum).Value w.Sheets("Galal").Cells(cell2.Row, c).Interior.Color = RGB(255, 255, 153) matched = True Exit For End If Next cell2 End If Next cell If matched Then MsgBox "تم الترحيل بنجاح!", vbInformation Else MsgBox "لم يتم العثور على أي رقم جلوس مطابق!", vbExclamation End If End Sub الملف غياب1.xlsm
-
السلام عليكم ورحمة الله وبركاته يتم التعديل في المتغيرات إزالة المتغير w2 لأننا لن نستخدم ملف خارجي تغيير جميع الإشارات من w2.Sheets("Total") إلى w.Sheets("Sheets3") للعمل مع الشيت المطلوب في نفس الملف اسم الشيت المرحل اليه Sheets3 Sub dahmour() Dim w As Workbook Dim L As String Dim r1 As Long, r2 As Long, c As Long Dim cell As Range, cell2 As Range Set w = ActiveWorkbook L = w.Sheets("Sheet2").[d2].Value If L <> "" Then r1 = w.Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row r2 = w.Sheets("Sheets3").Cells(Rows.Count, 1).End(xlUp).Row c = w.Sheets("Sheets3").Range("K13:KJ13").Find(L, LookAt:=xlWhole).Column For Each cell In w.Sheets("Sheet2").Range("a11:a" & r1) For Each cell2 In w.Sheets("Sheets3").Range("H14:H" & r2) If cell2.Value = cell.Value Then w.Sheets("Sheets3").Cells(cell2.Row, c) = w.Sheets("Sheet2").Cells(cell.Row, [k4]).Value Exit For End If Next cell2 Next cell End If End Sub
-
وعليكم السلام ورحمة الله وبركاته الأخ الكريم صاحب الكلمة الطيبة والمشاعر النبيلة، الفاضل / algammal أسعد الله قلبك كما أسعدتنا بكلماتك التي فاحت منها الطيبة والوفاء، ووالله إنها لوسام على صدورنا، ودافع لنا لنستمر في العطاء ما حيينا. نحن لم نقدّم إلا واجبًا يسيرًا، وما نحن إلا تلاميذ في هذا الصرح الطيب، ننهل ونتعلم ونتشارك. وسعادتنا الحقيقية أن نرى ثمرة هذا التعاون في نفوس طيبة مثلكم. بمناسبة عيد الأضحى المبارك، أتقدّم إليك وإلى جميع الإخوة والأعضاء الكرام بأطيب التهاني والتبريكات، أعاده الله علينا وعليكم بالخير واليمن والبركات، وتقبّل الله طاعاتكم، وبلغكم منازل الأبرار ، وأكرمكم بالعفو والعافية والغفران ، ووفقكم لما يحب ربنا ويرضاه ، لكم مني خالص المحبة والتقدير،
-
وعليكم السلام ورحمة الله وبركانه لم توضح ارتباط العمود الثاتي بأيعم ود في الشيت اليك التعديل Private Sub TextBox1_Change() ListBox1.Clear Application.ScreenUpdating = False Dim ws As Worksheet: Set ws = Sheets("add") Dim lr As Long, c As Range, b As Integer, k As Long Dim arrData() As Variant Dim i As Long, j As Long lr = 0 For Each c In ws.Range("b5:b" & ws.Cells(ws.Rows.Count, "B").End(xlUp).Row) b = InStr(1, c.Value, TextBox1.Value, vbTextCompare) If b > 0 Then lr = lr + 1 ReDim Preserve arrData(1 To 2, 1 To lr) arrData(1, lr) = c.Value arrData(2, lr) = c.Offset(0, 4).Value End If Next c With ListBox1 .ColumnCount = 2 .ColumnWidths = "100;100" If lr > 0 Then .List = Application.Transpose(arrData) End If End With Application.ScreenUpdating = True End Sub في الكود السابق تم ربط العمود الثاني باسم المعلم يمكنك التعديل يالتغيير في رقم 4 فهي تشير الى رقم العمود في الشيت بعد عمود الاسم arrData(2, lr) = c.Offset(0, 4).Value كنا يمكنك من تعديل عرض العمود بالتعديل في رقمي 100 الاول للعمود الاول والثانية للعمود الثاني .ColumnWidths = "100;100" ارجو ما قدمته ان يكون طلبك كل عام وانت بخير المرحليات أوفيسنا.xlsm
-
عملت الكود ده لكن تقيل جدا
عبدالله بشير عبدالله replied to الخطيب بيبوو's topic in منتدى الاكسيل Excel
السلام عليكم ورحمة الله وبركاته تم تحسين سرعة الكود اي تغيير في I2 -13-14 يعمل الكود الترقيم التلقائي في العمود B تم تعديل المعادلة في العمود الاخير بحيت تظعر الارقام حيب اخر بيان في العمود C جرب الكود وان كان هناك أي استفسار فلا حرج اعاده الله عليك يالخير والبركة يومية النقدية 1العامة.xlsm -
ضم (Macro1) و (Macro2) معا وتوحيد البحث في شيت واحد
عبدالله بشير عبدالله replied to algammal's topic in منتدى الاكسيل Excel
السلام عليكم ورحمة الله وبركاته بعد ملاحظة ااستاذنا الفاضل محمد هشام. جزاه الله خيرا والتي ذكر فيها بعد مراجعة الملف المقدم من أستاذنا الفاضل @عبدالله بشير عبدالله لاحظنا أنك تعتمد على معيار واحد فقط لجلب البيانات وليس عدة معايير كما ظننا في البداية لو عرفنا هذا منذ البداية لكان بإمكاننا تقديم حلول أبسط مما تم تطبيقه ضمن اليوزرفورم حيث كنا نعتقد أنك تحتاج بحثا ديناميكيا بعدة معايير وتعليقكم وكما اشار معلمنا الفاضل اليك الملف يبحث بعدة معايير لكما كل الود والتقدير والاحترام طريقة اخرى للبحث بعدة معايير.xlsb -
ضم (Macro1) و (Macro2) معا وتوحيد البحث في شيت واحد
عبدالله بشير عبدالله replied to algammal's topic in منتدى الاكسيل Excel
وعليكم السلام ورحمة الله وبركاته 4 طرق لمسح البيانات 1- زر به كود مسخ البيانات (جديد) يقوم الزر بنفس وظيفة الخلية الفارغة 2- اخنيار الخلية الفارغة من E5 (بعد عمل زر المسخ ليس لها ضرورة ) 3- الخروج من شيت SEARCH ثم العودة اليه 4- النقر مرتين في اي خلية في شيت SEARCH وايسرها كما تفضلتم زر المسح او النقر مرنين كما انوه ان تحديث البيانات اظافة وظيفة جديدة ..... الخ الى شيت DATA او معاشات يتم تلقائيا مع الانتباه لزيادة مدى البيانات للقائمة من التحقق من صحة البيانات انمنى اتى قدمت ما بقيد وما زال الباب مفتوحا لمفترحاتكم او ملاحظاتكم وكل عام وانتم بالف خير طريقة اخرى للبحث معدلة7.xlsb -
كود طباعة شيت اكسل لايعمل
عبدالله بشير عبدالله replied to ميسون الدايني's topic in منتدى الاكسيل Excel
وعليكم السلام ورحمة الله وبركاته ملفك لا بحتوى على اي كود تم عمل كود لطلبك والكود مرن يطبع الى اخر صف قيه بيانات Sub PrPAGES() Dim printWS As Worksheet Dim lastRow As Long Dim printRange As Range Set printWS = ThisWorkbook.Sheets("S1") lastRow = printWS.Cells(printWS.Rows.Count, "A").End(xlUp).Row Set printRange = printWS.Range("A1:C" & lastRow) printWS.PageSetup.PrintArea = printRange.Address printWS.PrintOut End Sub 1نموذج.xlsb -
ضم (Macro1) و (Macro2) معا وتوحيد البحث في شيت واحد
عبدالله بشير عبدالله replied to algammal's topic in منتدى الاكسيل Excel
السلام عليكم ورحمة الله وبركاته عذرا لتأخرى في الرد حسب الصورة المرفقة مع ردكم الكريم اظافة عنصر فارغ في القائمة e5 وبناء عليه تكون b10&g10 فارغتان تم التعديل و يمكنك تعديل نطاق القائمة كما تشاء يمكنك الاسنغناء عن زر انقر هنا للبحث وإذا لاحظت أي شيء يحتاج تعديل أو عندك أي فكرة تحب نضيفها، أنا حاضر بأي وقت، لك كل الود والتقدير طريقة اخرى للبحث معدلة6.xlsb -
وعليكم السلام ورحمة الله وبركاته اليك الكود المتاسب لطلبك Sub call1() Sheets("ff").Range("D3:U3").ClearContents Dim i As Integer For i = 1 To Sheets.Count Sheets("ff").Cells(3, 3 + i) = Sheets(i).Name Next i End Sub
-
ضم (Macro1) و (Macro2) معا وتوحيد البحث في شيت واحد
عبدالله بشير عبدالله replied to algammal's topic in منتدى الاكسيل Excel
السلام عليكم ورحمة الله وبركاته جرب التعديل التالى حسب طلبكم الاخير وفقكم الله طريقة اخرى للبحث معدلة5.xlsb -
ضم (Macro1) و (Macro2) معا وتوحيد البحث في شيت واحد
عبدالله بشير عبدالله replied to algammal's topic in منتدى الاكسيل Excel
السلام عليكم ورحمة الله وبركاته -
وعليكم السلام ورحمة الله وبركاته كمثال حساب1 =SUMIF($E$5:$E$1000; J5; $F$5:$F$1000) هي معادلة Excel تستخدم دالة SUMIF لجمع القيم بناءً على شرط معين تركيب الدالة SUMIF(range, criteria, [sum_range]) range: النطاق الذي يحتوي على القيم التي سيتم فحصها بناءً على الشرط. criteria: الشرط الذي يجب أن يتحقق لكي تتم عملية الجمع. sum_range: (اختياري) النطاق الذي سيتم جمع القيم منه إذا تحقق الشرط. شرح الدالة $E$5:$E$1000 → هذا هو نطاق الشرط: Excel سيبحث فيه عن القيم التي تساوي قيمة الخلية J5. J5 → هذا هو الشرط: نبحث عن الخلايا في العمود E التي تحتوي على نفس القيمة الموجودة في J5. $F$5:$F$1000 → هذا هو نطاق الجمع: إذا تم العثور على تطابق في العمود E، سيتم جمع القيمة المقابلة له في نفس الصف من العمود F. يوجد يديل اخر لها نفس النتيجة =SUMPRODUCT(($E$5:$E$1000=J5) * $F$5:$F$1000) ملاحظة / النطاق الى الصف 1000 يمكن زيادته او تقليله وجعلته 1000 حسب قولك ان العدد يمكن ان يكون اكثر اتمنى ان تجد ما يفيد في الشرح اعلاه لك كل التقدير والاحترام
-
ضم (Macro1) و (Macro2) معا وتوحيد البحث في شيت واحد
عبدالله بشير عبدالله replied to algammal's topic in منتدى الاكسيل Excel
وعليكم السلام ورحمة الله وبركاته جزاكم الله خيرًا على كلماتكم الطيبة ومشاعركم النبيلة، التي أعتز بها كثيرًا. لا يسعني إلا أن أبادلكم الدعاء بمثله وأكثر، وأسأل الله أن يديم بيننا المحبة والاحترام، وأن يوفقنا وإياكم لما فيه الخير والصلاح لكم ما طلبتم في انتظار ردكم من خلال تجربتكم للملف طريقة اخرى للبحث معدلة2.xlsb -
وعليكم السلام ورخمة الله وبركاته اليك الملف حسب فهمى لطلبك الحساب.xlsx
-
ضم (Macro1) و (Macro2) معا وتوحيد البحث في شيت واحد
عبدالله بشير عبدالله replied to algammal's topic in منتدى الاكسيل Excel
السلام عليكم جميعا ورحمة الله وبركاته الاستاذ الفاضل algammal بداية من اخر استفسار لكم هذا الزر غير ضرورى قمت بعمله بداية ثم نسيت ان احذفه بالتسبة للقوائم المتسدلة جعلتها مرنه بحيث يتم احضار البياتات الفعلية من العمود فقط فمثلا حاليا سن الخروج كلها 60 ستجد في القائمة 60 فقط واذا اضفت مثلا اي سن خروج اخرى في شيت معاشات او DATA ستجدها في القائمة وكذلك لباقى القوائم الاخرى لها تفس الخاصية اعتقد تقصد كل المهن الموجودة في الخلية E5 وليس B5 هذا حسب فهمى لطلبكم وفي اتنظار ملاحظايكم كما احب ان اتوه فكرة الاستاذ @محمد هشام. رائعة جدا وتحتاج الى تعديل في الكود لكي يتم البحث في شيت معاشات اظافة الى شيت DATA لان البياتات في شيت معاشات تم ترحيلها من شيت DATA الى معاشات وتم حذفها من شيت DATA بعد الترحيل في اتنظار تعديل الكود وفقه الله وجزاه الله خيرا لكم جميعا اطيب التحيات طريقة اخرى للبحث معدلة1.xlsb -
ضم (Macro1) و (Macro2) معا وتوحيد البحث في شيت واحد
عبدالله بشير عبدالله replied to algammal's topic in منتدى الاكسيل Excel
السلام عليكم ورحمة الله وبركاته الاستاذ الفاضل algammal جزاك الله كل خيرا على ثتاؤك ودعائك لي الاستاذ الفاضل Foksh تحية لك ولاخواننا في منتدى الاكسس بعد اذنكما ساطرح فكرة اخرى لطلب حبيبنا algammal حسب فهمى لطلبكم انكم تريدون البحث باسم الموظف او الرقم الوطني او من وظيفتهم طبيب كمثال اذا كان هذا الطلب فليس من الضرورى تجميع الاسماء في شيت واحد لان هذا سيزيد من حجم الملف وتكرار بيانات ليس لها ضرورة الفكرة كود يقوم بالبحث في شيت معاشات وشيت data باستخذام النطاق a5:m5 في شيت search ونتيجة البحث ينم وضعها في نفس الشيت بداية من A10 تم عمل قائمة بالاسماء بدل كنابنها ويتم تحديثها يدويا بواسطة زر وتتحدث تلقائيا عتد الانتهاء من البحث الملف المرفق يوضح الفكرة لكما ولكل اعضاء المنتدى وافر التقدير والاخترام طريقة اخرى للبحث.xlsb -
ترحيل البيانات من شيت إلى عدة شيتات مستقلة
عبدالله بشير عبدالله replied to algammal's topic in منتدى الاكسيل Excel
شكرا استاذنا الفاضل محمد هشام. على اطرائك كود متقن فائف السرعة سلمت يمينك وزادك من فضله وعلمه -
ترحيل البيانات من شيت إلى عدة شيتات مستقلة
عبدالله بشير عبدالله replied to algammal's topic in منتدى الاكسيل Excel
السلام عليكم ورحمة الله وبركاته أستاذنا ومعلمنا الفاضل، خبير الأكسس Foksh شرفٌ كبير لنا تواجدكم بيننا، فأنتم إضافة مميزة بأي مكان تحلون فيه. أتابع ردودكم وحلولكم الاحترافية باهتمام في منتدى الاكسس، ونتعلم منها الكثير، فجزاكم الله خيرًا. كما لا يفوتني أن أوجه التحية والتقدير لأخينا الحبيب، الأستاذ الفاضل algammal. تحياتي واحترامي لك أخي العزيز، وبعد إذن معلمنا، هذه محاولة متواضعة لتنفيذ طلب أخينا العزيز، حسب ما فهمته من سؤاله. أتمنى أن تقوم بتجربة الحل، وإذا كان هناك أي تعديل أو توضيح إضافي، فأنا على أتم الاستعداد . مع خالص التحية والتقدير لكما ولكل منابعى المنتدى، الكود Sub ترحيل_البيانات() Dim wsMain As Worksheet, wsNew As Worksheet Dim dict As Object, dataArray As Variant Dim i As Long, lastRow As Long, targetRow As Long Dim startTime As Double: startTime = Timer Dim sheetName As String With Application .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False .DisplayAlerts = False .StatusBar = "جاري معالجة البيانات مع الحفاظ على التنسيقات..." End With On Error GoTo ErrorHandler Set wsMain = ThisWorkbook.Sheets("معاشات") Set dict = CreateObject("Scripting.Dictionary") lastRow = wsMain.Cells(wsMain.Rows.Count, "A").End(xlUp).Row If lastRow < 5 Then Exit Sub dataArray = wsMain.Range("A5:M" & lastRow).Value For i = 1 To UBound(dataArray, 1) sheetName = Trim(dataArray(i, 5)) If sheetName <> "" Then dict(sheetName) = Empty Next i Application.DisplayAlerts = False For Each wsNew In ThisWorkbook.Worksheets If Not wsNew Is wsMain Then If dict.exists(wsNew.Name) Then wsNew.Delete End If Next wsNew Application.DisplayAlerts = True Dim key As Variant, rowIndex As Long For Each key In dict.keys Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) wsNew.Name = key wsNew.DisplayRightToLeft = True wsMain.Range("A1:M4").Copy wsNew.Range("A1").PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = False wsMain.Rows("3:4").Copy wsNew.Rows("3:4").PasteSpecial Paste:=xlPasteAll Application.CutCopyMode = False targetRow = 5 For rowIndex = 1 To UBound(dataArray, 1) If Trim(dataArray(rowIndex, 5)) = key Then wsMain.Range("A" & rowIndex + 4 & ":M" & rowIndex + 4).Copy wsNew.Range("A" & targetRow) targetRow = targetRow + 1 End If Next rowIndex For i = 1 To wsMain.UsedRange.Rows.Count If i <= wsNew.UsedRange.Rows.Count Then wsNew.Rows(i).RowHeight = wsMain.Rows(i).RowHeight End If Next i For i = 1 To 13 wsNew.Columns(i).ColumnWidth = wsMain.Columns(i).ColumnWidth Next i Next key wsMain.Activate CleanUp: With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .EnableEvents = True .DisplayAlerts = True .StatusBar = False End With ' MsgBox "تم الانتهاء في " & Format(Timer - startTime, "0.00") & " ثانية", vbInformation Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical Resume CleanUp End Sub الملف ترحيل البيانات من شيت إلى عدة شيتات مستقلة.xlsb -
تعديل كود ترحيل بيانات موظف محال للمعاش
عبدالله بشير عبدالله replied to algammal's topic in منتدى الاكسيل Excel
وعليكم السلام ورحمة الله وبركاته أخي الكريم، كلماتك غمرتني بفيض من المشاعر الطيبة، ولا يسعني إلا أن أحمد الله على هذا الودّ الخالص في الله، وعلى هذا الدعاء النبيل الذي لامس القلب قبل العين. أسأل الله أن يرفع قدرك، ويشرح صدرك، ويبارك فيك وفي أهلك وذريتك، وأن يرزقك سعادة الدارين، ويجمعنا دائمًا على طاعته وفي ظله يوم لا ظل إلا ظله. رحم الله من دعا لهم قلبك، وأسكنهم فسيح جناته، وجعل دعاءك لهم ولنا شاهدًا لك يوم تلقاه، وكتب لك من كل حرف كتبته نورًا يضيء دربك في الدنيا والآخرة. أحبك الله الذي أحببتنا فيه، وجمعنا وإياك على الخير، وفي الجنة على سررٍ متقابلين