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

وعليكم السلام ورحمة الله وبركاته اكتب التاريخ واسم المدرسة ثم اضغظ على زر بحث Sub SearchAndTransfer() Dim wsPlan As Worksheet Dim wsSearch As Worksheet Dim lastRowPlan As Long Dim lastRowSearch As Long Dim i As Long, j As Long Dim searchDate As String Dim searchSchool As String Dim dateFound As Boolean Set wsPlan = ThisWorkbook.Sheets("الخطة") Set wsSearch = ThisWorkbook.Sheets("بحث بالمدرسة") lastRowPlan = wsPlan.Cells(wsPlan.Rows.Count, "B").End(xlUp).Row searchDate = wsSearch.Range("D1").Value searchSchool = wsSearch.Range("C4").Value wsSearch.Rows("9:" & wsSearch.Rows.Count).ClearContents lastRowSearch = 9 For i = 6 To lastRowPlan dateFound = False For j = 5 To 31 ' المدى E5:AE5 يعني الأعمدة من 5 إلى 45 If wsPlan.Cells(5, j).Value = searchDate And wsPlan.Cells(i, j).Value = searchSchool Then dateFound = True Exit For End If Next j If dateFound Then wsSearch.Cells(lastRowSearch, 1).Value = lastRowSearch - 8 wsSearch.Cells(lastRowSearch, 2).Value = wsPlan.Cells(i, 3).Value wsSearch.Cells(lastRowSearch, 3).Value = wsPlan.Cells(i, 4).Value lastRowSearch = lastRowSearch + 1 End If Next i If lastRowSearch = 9 Then MsgBox "لم يتم العثور على أي بيانات ." Else MsgBox "تم نقل البيانات بنجاح!" End If End Sub بحث1.xlsb

يمكنك استخدام كود 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`. بالتوفيق

لن تتاثر القاعدة المقسمة وستكون النتيجة واحدة

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

اخي الكريم صاحب الاستفسار انا ما شفت الملف لأني على الموبايل لذلك قمت بترجمة ما قلته حضرتك الي معادلة هذه الجملة تعني انك تريد تاريخ قبل G2 بمدة من شهر الي 60 شهر سابق وهذا ما تقوم به المعادلة أما حكاية تغيير قيمة الخلية لأنها تنشئ رقما عشوائيا وإذا أردت تثبيت المدة مثلا تاريخ سابق ل G2 بعشرين شهر أو 30 شهر يمكنك تغيير الجزء الخاص ب RANDBETWEEN الي هذا الرقم الثابت انا دائما اعطي فكرة الحل وليس الحل امتثالا للحكمة القائلة لا تعطني سمكة ولكن علمني كيف اصطاد فكرتي هي استخدام EDATE يمكنك توظيفها كما تشاء بالتوفيق

هذا الكود سيحذف جميع الصفوف التي تحتوي على قيم غير فريدة في العمود المحدد بمعنى سيتم حذف جميع الصفوف التي تحتوي على قيم متكررة، بما في ذلك النسخة الأولى لكل قيمة Sub RemoveAllDuplicates() Dim f As Worksheet Dim Irow As Long, i As Long Dim dict As Object, tmp As Variant Dim uniqueDict As Object Dim n As Long Dim Col As String: Col = "A" Dim startRow As Long: startRow = 2 Set f = ThisWorkbook.Sheets("Sheet1") Irow = f.Cells(f.Rows.Count, Col).End(xlUp).Row Set dict = CreateObject("Scripting.Dictionary") Set uniqueDict = CreateObject("Scripting.Dictionary") n = 0 For i = startRow To Irow tmp = f.Cells(i, Col).Value If tmp <> "" Then If dict.exists(tmp) Then dict(tmp) = dict(tmp) + 1 Else dict.Add tmp, 1 End If End If Next i For i = Irow To startRow Step -1 tmp = f.Cells(i, Col).Value If tmp <> "" Then If dict(tmp) > 1 Then f.Rows(i).Delete n = n + 1 ElseIf dict(tmp) = 1 And uniqueDict.exists(tmp) Then f.Rows(i).Delete n = n + 1 Else uniqueDict.Add tmp, True End If End If Next i If n > 0 Then MsgBox "تم حذف جميع التكرارات" & vbCrLf & _ vbCrLf & "عدد الصفوف المحذوفة: " & n, vbInformation Else MsgBox "لم يتم العثور على أي تكرارات", vbInformation End If End Sub Supprimer_les_doublon.xlsb

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

جزاكم الله خير جميعا على مجهودكم العظيم

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

الاساتذه الأفاضل اشكركم علي المساعدة الثمينه الاستاذ / محمد هشام الاستاذ / محمدصالح شكرا علي الجهد المبزول لمساعدتنا

اتمنى اني فهمت عنك انظر المرفق aa.rar

وعليكم السلام ورحمة الله تعالى وبركاته صراحة لقد جربت الكود الخاص بك يشتغل بشكل جيد لاكن يمكنك تجربة هدا ربما يكون أسرع قم بحدف جميع الأكواد الموجودة داخل اليوزرفورم وضع الأكواد التالية Option Compare Text Dim f, TblPRODUCT, Col(), OneRng Private Sub UserForm_Initialize() Set f = Sheets("PRODUCT") TblPRODUCT = f.Range("A2:D" & f.[A65000].End(xlUp).Row).Value Col = Array(1, 2, 3, 4) OneRng = UBound(Col) + 1 filtre HideBar Me End Sub Sub filtre() temp1 = "*" & Me.TextBox6 & "*" temp2 = "*" & Me.TextBox5 & "*" Dim Tbl(): n = 0 For I = 1 To UBound(TblPRODUCT) If TblPRODUCT(I, 1) Like temp1 And TblPRODUCT(I, 2) Like temp2 Then n = n + 1: ReDim Preserve Tbl(1 To OneRng, 1 To n) c = 0 For Each k In Col c = c + 1: Tbl(c, n) = TblPRODUCT(I, k) Next k End If Next I If n > 0 Then Me.ListBox1.Column = Tbl Else Me.ListBox1.Clear End If Me.TextBox7.Value = n End Sub Private Sub TextBox6_Change() filtre End Sub Private Sub TextBox5_Change() filtre End Sub Private Sub ListBox1_Click() If Me.ListBox1.ListIndex <> -1 Then Me.TextBox1.Value = Me.ListBox1.Column(0, Me.ListBox1.ListIndex) Me.TextBox2.Value = Me.ListBox1.Column(1, Me.ListBox1.ListIndex) Me.TextBox3.Value = Me.ListBox1.Column(2, Me.ListBox1.ListIndex) Me.TextBox4.Value = Me.ListBox1.Column(3, Me.ListBox1.ListIndex) End If End Sub Private Sub UserForm_Activate() Me.Label23.Caption = Date UpdateTime End Sub Private Sub UpdateTime() Dim r As Long Dim startTime As Double startTime = Timer Do While Timer < startTime + 1 Me.Label22.Caption = Format(Now, "h:mm:ss") DoEvents For r = 1 To 100000: Next r Loop UpdateTime End Sub Private Sub CommandButton1_Click() ThisWorkbook.Save Application.Quit End Sub Private Sub CommandButton2_Click() Application.Visible = True Unload Me End Sub وفي Module1 Option Explicit #If VBA7 Then Public Declare PtrSafe Function FindWindow Lib "user32" _ Alias "FindWindowA" _ (ByVal lpClassName As String, _ ByVal lpWindowName As String) As Long Public Declare PtrSafe Function GetWindowLong Lib "user32" _ Alias "GetWindowLongA" _ (ByVal hWnd As Long, _ ByVal nIndex As Long) As Long Public Declare PtrSafe Function SetWindowLong Lib "user32" _ Alias "SetWindowLongA" _ (ByVal hWnd As Long, _ ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long Public Declare PtrSafe Function DrawMenuBar Lib "user32" _ (ByVal hWnd As Long) As Long #Else Public Declare Function FindWindow Lib "user32" _ Alias "FindWindowA" _ (ByVal lpClassName As String, _ ByVal lpWindowName As String) As Long Public Declare Function GetWindowLong Lib "user32" _ Alias "GetWindowLongA" _ (ByVal hWnd As Long, _ ByVal nIndex As Long) As Long Public Declare Function SetWindowLong Lib "user32" _ Alias "SetWindowLongA" _ (ByVal hWnd As Long, _ ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long Public Declare Function DrawMenuBar Lib "user32" _ (ByVal hWnd As Long) As Long #End If Sub HideBar(frm As Object) Dim Style As Long, Menu As Long, hWndForm As Long hWndForm = FindWindow("ThunderDFrame", frm.Caption) Style = GetWindowLong(hWndForm, &HFFF0) Style = Style And Not &HC00000 SetWindowLong hWndForm, &HFFF0, Style DrawMenuBar hWndForm End Sub أسعار القطع.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

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

اظافة ما تفضل به معلمنا محمد صالح ومعلمنا محمد هشام يمكن استخدام المعادلة التالية فى حالة وضعها في عمود اخر =CONCATENATE("'"; A2) Copy of OverTime Transaction Upload Template.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته لاستخراجها في عمود مغاير يكفي استخدام المعادلة التالية =IF(A2<>"", "'" & A2, "") اما بالنسبة لاستخدام الأكواد يمكنك استخدام طريقة أكثر كفاءة واسرع خاصة عند وجود عدد كبير من البيانات من خلال تقليل عدد عمليات الكتابة إلى الخلايا. بدلاً من تعديل كل خلية فردياً في حلقة يمكنك استخدام مصفوفات لتخزين القيم مؤقتاً ثم كتابة البيانات مرة واحدة فقط مع ضمان عدم التعديل على الخلايا الفارغة Sub test() Dim f As Worksheet Dim tmp As Variant Dim i As Long, lastRow As Long Application.ScreenUpdating = False Set f = ThisWorkbook.Sheets("Sheet1") lastRow = f.Cells(f.Rows.Count, "A").End(xlUp).Row tmp = f.Range("A2:A" & lastRow).Value For i = 1 To UBound(tmp, 1) If tmp(i, 1) <> "" Then tmp(i, 1) = "'" & tmp(i, 1) End If Next i f.Range("A2:A" & lastRow).Value = tmp Application.ScreenUpdating = True End Sub Copy of OverTime.xlsb