نجوم المشاركات

وعليكم السلام ورحمة الله وبركاته السؤال واضح ولكن وضع فكرة السؤال في كود تحتاج الى وقت لجعل العمل بالملف بطريقة مبسطة وليست معقدة المهم فكرة الكود الحالية بدون اي InputBox ملفك به عدة صفحات كل صفحة بمرتبة معينة اذا اردت تغيير المراتب فمثلا في صفحة مرتبة 6 قم بتغييرعدد من الموظفين الى مراتب جديدة متساوية او مختلفة ثم اذهب الى صفحة مرتبة9 مثلا وقم بتغيير مراتب موظفين الى مراتب اعلى او اقل عند الضغظ على الزر يتم حذف من تغييرت مراتبهم من صفحاتهم وترحليهم كل الى صفحته والكود يرحل من مرتبة اقل الى اعلى او العكس بالمختصر خطوتان الاولى امام اي موظف غير المرتبة المطلوبة لاي عدد تشاءوفي اي صفحة الثانية الضغظ على الزر الكود Sub TransferEmployeeData() Dim ws As Worksheet Dim targetWs As Worksheet Dim lastRow As Long Dim i As Long Dim rank As String Dim targetRank As String Dim targetRow As Long Dim data As Variant Dim targetData As Variant Dim targetLastRow As Long Application.ScreenUpdating = False Application.Calculation = xlCalculationManual For Each ws In ThisWorkbook.Worksheets If Left(ws.Name, 7) = "المرتبة" Then lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row For i = lastRow To 2 Step -1 rank = ws.Cells(i, 4).Value If rank <> Mid(ws.Name, 9) Then On Error Resume Next Set targetWs = ThisWorkbook.Worksheets("المرتبة " & rank) On Error GoTo 0 If Not targetWs Is Nothing Then targetLastRow = targetWs.Cells(targetWs.Rows.Count, "A").End(xlUp).Row + 1 targetWs.Rows(targetLastRow).Value = ws.Rows(i).Value ws.Rows(i).Delete End If End If Next i End If Next ws Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub الملف ترحيل موظف1 (1).xlsb

السلام عليكم وبها نبدأ اي موضوع نسخ كل عمود مستقل الي الورقه الهدف في نفس العمود مع امكانيه تغيير الاعمده المرحل إليها بمعني ترحيل الاعمده b5:b200و c5:c200 و d5:d200 الي ورقه الهدف إما إلي نفس الاعمده او غيرها أي أقوم بتعديلها بنفسي في الكود يعني كود اقدر اغير في الاعمده المرحل منها وإليها كود اعدل عليه بالاضافه او الحذف في الاعمده فى range الكود نفسه ترحيل على حسب المطلوب فى العمل.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا ربما يناسبك Module Sub ProtectWS() Dim sh As Variant, MyArray As Variant, Password As String Password = "1234" MyArray = Array(Sheet1, Sheet2) ' <<=== ' اسماء الاوراق المرغوب حمايتها For Each sh In MyArray sh.Protect Password, UserInterfaceOnly:=True, AllowFiltering:=True Next sh End Sub ThisWorkbook Private Sub Workbook_Open() ProtectWS End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) ProtectWS End Sub وفي حدث الاوراق المحددة Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim Password As String Dim Clé As String Password = "1234" ' الباسوورد الخاص بك If Me.ProtectContents Then Clé = InputBox(" الورقة محمية يرجى إدخال كلمة المرور") If Clé = Password Then Me.Unprotect Password Else MsgBox "كلمة المرور غير صحيحة", vbCritical Exit Sub End If End If End Sub ' في جالة الرغبة بنسخ البيانات من ورقة لاخرى يمكنك تعطيل الكود التالي Private Sub Worksheet_Deactivate() Dim Password As String Password = "1234" Me.Protect Password End Sub test.xlsb

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

وعليكم السلام ورحمة الله تعالى وبركاته بعد معاينة النتيجة المتوقعة جرب وضع الصيغ التالية F2 =IF(OR(A2="احاله", A2="وفاه"), IF(DATEDIF(C2,D2,"y")>=5, 0, DATEDIF(C2,D2,"md")), DATEDIF(B2,E2,"md")) G2 =IF(OR(A2="احاله", A2="وفاه"), IF(DATEDIF(C2,D2,"y")>=5, 60, DATEDIF(C2,D2,"m")), DATEDIF(B2,E2,"m")) الفرق بين تاريخين لاكثر من شرط.xlsx

Sub Copier_Les_Valeurs_With_formats_Advanced() 'Variables On Error GoTo ErrorHandler Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual ' قم بتحديد الأعمدة المرحلة بما يناسبك DataCols = Array("B", "C", "D") ' قم بتحديد الأعمدة المرحل اليها DestCols = Array("B", "C", "D") 'Code............ If dest Is Nothing Then MsgBox "إسم الشهر غير صحيح يرجى التحقق والمحاولة مرة أخرى", vbExclamation GoTo Cleanup End If f = True For j = LBound(DataCols) To UBound(DataCols) lastRow = ws.Cells(ws.Rows.Count, DataCols(j)).End(xlUp).Row Set DataRng = ws.Range(DataCols(j) & "5:" & DataCols(j) & lastRow) If Application.WorksheetFunction.CountA(DataRng) > 0 Then f = False destCol = dest.Columns(DestCols(j)).Column With dest.Range(dest.Cells(5, destCol), dest.Cells(dest.Rows.Count, destCol)) .ClearContents .ClearFormats End With Set destRng = dest.Range(dest.Cells(5, destCol), _ dest.Cells(lastRow, destCol)) destRng.value = DataRng.value DataRng.Copy destRng.PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = False End If Next j If f Then MsgBox WSname & " لا يوجد بيانات للنسخ في جميع الأعمدة المحددة", vbExclamation GoTo Cleanup End If MsgBox "تم نسخ البيانات من شهر " & WSname & " إلى شهر " & destName & " بنجاح:", vbInformation Cleanup: Application.ScreenUpdating = True Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical Resume Cleanup End Sub وكما جاء في طلبك الاول بمعني ترحيل الاعمده b5:b200و c5:c200 و d5:d200 بدلاً من تحديد آخر صف يحتوي على بيانات يمكنك استخدام النطاق الثابت بين الصفوف 5 و 200 For j = LBound(DataCols) To UBound(DataCols) ' تحديد النطاق الثابت من الصف 5 إلى الصف 200 Set DataRng = ws.Range(DataCols(j) & "5:" & DataCols(j) & "200") If Application.WorksheetFunction.CountA(DataRng) > 0 Then f = False destCol = dest.Columns(DestCols(j)).Column With dest.Range(dest.Cells(5, destCol), dest.Cells(200, destCol)) .ClearContents .ClearFormats End With Set destRng = dest.Range(dest.Cells(5, destCol), dest.Cells(200, destCol)) destRng.value = DataRng.value DataRng.Copy destRng.PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = False ترحيل على حسب المطلوب فى العمل.xlsm

تفضل aa (1).rar

وعليكم السلام ورحمة الله وبركاته 🙂 يمكنك الاستعانة بهذا الجدول لعمل قناع إدخال بيانات حسب المطلوب : وحسب سؤالك فأعتقد أن هذا هو القناع المناسب : طبعا هذا القناع إما أن تضعه في خانة قناع الإدخال للحقل في النموذج : أو أن تضعه في خانة قناع الإدخال للحقل في الجدول.

وعليكم السلام ورحمة الله وبركاته اللهم كن عونا وتصيرالاخواننا في فلسطين كان من المفترض ازالة الحماية من محرر الاكواد وحاولت بكلمة دارفشيان فلم تنجح , على كل حال تم فتح محرر الاكواد بطريقتى الخاصة ولكن جميع الاكواد غير موجودة ما يهمك الكود التالي انقله الى ملفك واربطه بزر الكود Sub ExportToWord1() Dim ws As Worksheet Dim wordApp As Object Dim wordDoc As Object Dim lastRow As Long Dim fileName As String Dim filePath As String Set ws = ThisWorkbook.Sheets("قائمة الأسماء") fileName = ws.Range("E4").Value If fileName = "" Then MsgBox "اسم الملف في الخلية E4 فارغ. يرجى إدخال اسم الملف." Exit Sub End If fileName = Application.WorksheetFunction.Clean(fileName) fileName = Replace(fileName, "/", "") fileName = Replace(fileName, "\", "") fileName = Replace(fileName, ":", "") fileName = Replace(fileName, "*", "") fileName = Replace(fileName, "?", "") fileName = Replace(fileName, """", "") fileName = Replace(fileName, "<", "") fileName = Replace(fileName, ">", "") fileName = Replace(fileName, "|", "") fileName = fileName & ".docx" filePath = ThisWorkbook.Path On Error Resume Next Set wordApp = GetObject(, "Word.Application") If Err.Number <> 0 Then Set wordApp = CreateObject("Word.Application") End If On Error GoTo 0 wordApp.Visible = True Set wordDoc = wordApp.Documents.Add lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row ws.Range("C1:E" & lastRow).Copy wordDoc.Content.Paste wordDoc.SaveAs2 filePath & "\" & fileName wordDoc.Close SaveChanges:=False wordApp.Quit Set wordDoc = Nothing Set wordApp = Nothing MsgBox "تم الترحيل بنجاح إلى الملف: " & fileName End Sub ____________ __________ ________ __________2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته استكمالا للموضوع السابق لترحيل بيانات الاعمدة المدكورة بدون تكرار بنفس الفكرة السابقة مع امكانية تحديدها او تعديلها عند الحاجة داخل الكود يمكنك استخدام الكود التالي Sub Uniques_specific_range_array() '********** نسخ بدون تكرارات ************ Dim WSname As String, destName As String Dim ws As Worksheet, dest As Worksheet Dim dict As Object, j As Integer, i As Long Dim DataRngs As Variant, DestCols As Variant, arr As Variant Dim tmp As Boolean, allEmpty As Boolean, dictKey As Variant Dim destCol As Integer, cellValue As Variant ' قم بتحديد الأعمدة المرحلة بما يناسبك DataRngs = Array("B5:B200", "C5:C200", "D5:D200") ' قم بتحديد الأعمدة المرحل اليها DestCols = Array("B", "C", "D") WSname = InputBox(" : يرجى إدخال إسم الشهر المرغوب ترحيله") If Len(Trim(WSname)) = 0 Then MsgBox " تم إلغاء الترحــيل", vbExclamation Exit Sub End If On Error Resume Next Set ws = ThisWorkbook.Sheets(WSname) On Error GoTo 0 If ws Is Nothing Then MsgBox "إسم الشهر غير صحيح يرجى التحقق والمحاولة مرة أخرى" Exit Sub End If destName = InputBox(" : يرجى إدخال إسم الشهر المرحل إليه") If Len(Trim(destName)) = 0 Then MsgBox " تم إلغاء الترحــيل", vbExclamation Exit Sub End If On Error Resume Next Set dest = ThisWorkbook.Sheets(destName) On Error GoTo 0 If dest Is Nothing Then MsgBox "إسم الشهر غير صحيح يرجى التحقق والمحاولة مرة أخرى" Exit Sub End If allEmpty = True For j = LBound(DataRngs) To UBound(DataRngs) arr = ws.Range(DataRngs(j)).value Set dict = CreateObject("Scripting.Dictionary") ' التحقق من وجود قيم على الأعمدة المرحلة tmp = Application.WorksheetFunction.CountA(ws.Range(DataRngs(j))) > 0 If tmp Then allEmpty = False For i = 1 To UBound(arr, 1) cellValue = arr(i, 1) If Len(cellValue) > 0 And Not dict.exists(cellValue) Then dict.Add cellValue, Nothing End If Next i ' إفراغ البيانات السابقة على الاعمدة المرحل إليها بداية من الصف 5 destCol = dest.Columns(DestCols(j)).Column With dest.Range(dest.Cells(5, destCol), dest.Cells(dest.Rows.Count, destCol)) .ClearContents: .ClearFormats End With '(نسخ القيم الفريدة) بداية من الصف 5 من ورقة الشهر المختارة i = 5 For Each dictKey In dict.Keys dest.Cells(i, destCol).value = dictKey i = i + 1 Next dictKey End If Next j If allEmpty Then MsgBox WSname & " " & "لا يوجد بيانات للنسخ في جميع الأعمدة المحددة" & " : " & "شهر", vbExclamation Exit Sub End If MsgBox "تم نسخ البيانات من شهر " & WSname & " إلى " & "شهر" & " " & destName & " " & " بنجاح", vbInformation End Sub ولنسخها مع وجود التكرارات اليك الكود التالي Sub Copier_Les_Valeurs_No_formatting() Dim WSname As String, destName As String Dim ws As Worksheet, dest As Worksheet Dim DataCols As Variant, DestCols As Variant Dim allEmpty As Boolean, srcData As Variant Dim j As Integer, lastRow As Long, DataRng As Range ' قم بتحديد الأعمدة المرحلة بما يناسبك DataCols = Array("B", "C", "D") ' قم بتحديد الأعمدة المرحل اليها DestCols = Array("B", "C", "D") WSname = InputBox(" : يرجى إدخال إسم الشهر المرغوب ترحيله") If Len(Trim(WSname)) = 0 Then MsgBox "تم إلغاء الترحــيل", vbExclamation Exit Sub End If On Error Resume Next Set ws = ThisWorkbook.Sheets(WSname) On Error GoTo 0 If ws Is Nothing Then MsgBox "إسم الشهر غير صحيح يرجى التحقق والمحاولة مرة أخرى" Exit Sub End If destName = InputBox(" : يرجى إدخال إسم الشهر المرحل إليه") If Len(Trim(destName)) = 0 Then MsgBox "تم إلغاء الترحــيل", vbExclamation Exit Sub End If On Error Resume Next Set dest = ThisWorkbook.Sheets(destName) On Error GoTo 0 If dest Is Nothing Then MsgBox "إسم الشهر غير صحيح يرجى التحقق والمحاولة مرة أخرى" Exit Sub End If allEmpty = True For j = LBound(DataCols) To UBound(DataCols) lastRow = ws.Cells(ws.Rows.Count, DataCols(j)).End(xlUp).Row ' تحديد النطاق بداية من الصف 5 Set DataRng = ws.Range(DataCols(j) & "5:" & DataCols(j) & lastRow) ' التحقق من وجود قيم على الأعمدة المرحلة If Application.WorksheetFunction.CountA(DataRng) > 0 Then allEmpty = False ' تحميل البيانات إلى مصفوفة srcData = DataRng.value ' إفراغ البيانات السابقة على الاعمدة المرحل إليه بداية من الصف 5 With dest.Range(dest.Cells(5, dest.Columns(DestCols(j)).Column), _ dest.Cells(dest.Rows.Count, dest.Columns(DestCols(j)).Column)) .ClearContents: .ClearFormats End With 'نسخ القيم بداية من الصف 5 من ورقة الشهر المختارة dest.Cells(5, dest.Columns(DestCols(j)).Column).Resize(UBound(srcData, 1), 1).value = srcData End If Next j If allEmpty Then MsgBox WSname & " " & "لا يوجد بيانات للنسخ في جميع الأعمدة المحددة" & " : " & "شهر", vbExclamation Exit Sub End If MsgBox "تم نسخ البيانات من شهر " & WSname & " إلى شهر " & destName & " بنجاح", vbInformation End Sub ترحيل على حسب المطلوب فى العمل.xlsm

يمكنك استخدام كود VBA في Excel لتحقيق ذلك. إليك مثال على كود يمكنك تعديله حسب الحاجة: Sub CopyColumns() Dim sourceSheet As Worksheet Dim targetSheet As Worksheet Dim sourceRange As Range Dim targetRange As Range ' تحديد الورقة المصدر والورقة الهدف Set sourceSheet = ThisWorkbook.Sheets("SourceSheetName") Set targetSheet = ThisWorkbook.Sheets("TargetSheetName") ' نسخ العمود B Set sourceRange = sourceSheet.Range("B5:B200") Set targetRange = targetSheet.Range("B5") sourceRange.Copy Destination:=targetRange ' نسخ العمود C Set sourceRange = sourceSheet.Range("C5:C200") Set targetRange = targetSheet.Range("C5") sourceRange.Copy Destination:=targetRange ' نسخ العمود D Set sourceRange = sourceSheet.Range("D5:D200") Set targetRange = targetSheet.Range("D5") sourceRange.Copy Destination:=targetRange End Sub يمكنك تعديل أسماء الأوراق والنطاقات حسب الحاجة. إذا كنت ترغب في تغيير الأعمدة المرحل إليها، يمكنك تعديل القيم في `targetRange`. بالتوفيق

وعليكم السلام ورحمة الله تعالى وبركاته ضع الكود التالي في Module Sub HideRowsWith_Zero() Dim Sh As Worksheet Dim i As Long, lastRow As Long Set Sh = ThisWorkbook.Sheets("تفاصيل") lastRow = Sh.Columns("A:C").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row For i = 4 To lastRow If Sh.Cells(i, 2).Value = 0 And Sh.Cells(i, 3).Value = 0 Then Sh.Rows(i).Hidden = True Else Sh.Rows(i).Hidden = False End If Next i End Sub وفي حدث ورقة تفاصيل Private Sub Worksheet_Activate() HideRowsWith_Zero End Sub اخفاء الصفوف.xlsb

تفضل مطلوب تفعيل إشعار إنتهاء فترة التجربة.xlsx

السلام عليكميكفي تغيير المعادلة في الخلية C26 في شيت Dashboard والتي هي : E22&""= بالمعادلة : E22= كما في الملف المرفق... بيان الربح والخسارة_Copy (3).xlsx

أخى سليم مشكور على الاضافة أنا لا أقصد من الدالة مجرد الفصل بين الاسماء ولكن أقصد استخلاص اسم محدد من اسم الشخص لو عندى اسم بالشكل ده : عبد الله عبد الرحمن نور الدين عبد الحافظ الكود الذى تفضلت به لا يمكنه استخلاص اسم الأب فقط أو الجد فقط أو اللقب فقط أرجو أن تكون الصورة واضحة الاخ خليل معذرة الموضوع متكرر تفضل Mokhtar Family New UDF.rar

جرب هذا الملف Split_names.rar أو يمكن استعمال هذا الماكرو من سطر واحد Sub Split_Names() Range("A2:A" & Cells(Rows.Count, "A").End(3).Row).TextToColumns Destination:=Range("B2"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Space:=True End Sub

الأستاذ / كرتوتي السلام عليكم ورحمة الله وبركاته بعد إذن الأستاذ الفاضل / أبو عيد جزاه الله خيراً على حله الرائع ولإثراء الموضوع إليك طريقة أخرى لعلها تفي بالغرض. الرسم البياني معدل1.rar

سيتم تغير سطرين الي ما يقابلهم For Each c In Sheets("Charts").Range("b1:f1") ComboBox2.AddItem Sheets("Charts").Cells(i, c.Column)

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